home *** CD-ROM | disk | FTP | other *** search
/ Supercompiler 1997 / SUPERCOMPILER97.iso / Delphi 3.0 / DATA.Z / dbtables.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-01-29  |  228.0 KB  |  8,354 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {       BDE Data Access                                 }
  6. {                                                       }
  7. {       Copyright (c) 1995,97 Borland International     }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11. unit DBTables;
  12.  
  13. {$R-}
  14.  
  15. interface
  16.  
  17. uses Windows, SysUtils, Graphics, Classes, Controls, Db, DBCommon, Bde, SMIntf,
  18.   StdVCL;
  19.  
  20. const
  21.  
  22. { SQL Trace buffer size }
  23.  
  24.   smTraceBufSize = 32767 + SizeOf(TraceDesc);
  25.  
  26. { TDBDataSet flags }
  27.  
  28.   dbfOpened     = 0;
  29.   dbfPrepared   = 1;
  30.   dbfExecSQL    = 2;
  31.   dbfTable      = 3;
  32.   dbfFieldList  = 4;
  33.   dbfIndexList  = 5;
  34.   dbfStoredProc = 6;
  35.   dbfExecProc   = 7;
  36.   dbfProcDesc   = 8;
  37.  
  38. type
  39.  
  40. { Forward declarations }
  41.  
  42.   TDBError = class;
  43.   TSession = class;
  44.   TDatabase = class;
  45.   TBDEDataSet = class;
  46.   TDBDataSet = class;
  47.   TTable = class;
  48.  
  49. { Generic types }
  50.  
  51.   PFieldDescList = ^TFieldDescList;
  52.   TFieldDescList = array[0..1023] of FLDDesc;
  53.  
  54.   PIndexDescList = ^TIndexDescList;
  55.   TIndexDescList = array[0..63] of IDXDesc;
  56.  
  57.   PSPParamDescList = ^TSPParamDescList;
  58.   TSPParamDescList = array[0..1023] of SPParamDesc;
  59.  
  60. { Exception classes }
  61.  
  62.   EDBEngineError = class(EDatabaseError)
  63.   private
  64.     FErrors: TList;
  65.     function GetError(Index: Integer): TDBError;
  66.     function GetErrorCount: Integer;
  67.   public
  68.     constructor Create(ErrorCode: DBIResult);
  69.     destructor Destroy; override;
  70.     property ErrorCount: Integer read GetErrorCount;
  71.     property Errors[Index: Integer]: TDBError read GetError;
  72.   end;
  73.  
  74.   ENoResultSet = class(EDatabaseError);
  75.  
  76. { BDE error information type }
  77.  
  78.   TDBError = class
  79.   private
  80.     FErrorCode: DBIResult;
  81.     FNativeError: Longint;
  82.     FMessage: string;
  83.     function GetCategory: Byte;
  84.     function GetSubCode: Byte;
  85.   public
  86.     constructor Create(Owner: EDBEngineError; ErrorCode: DBIResult;
  87.       NativeError: Longint; Message: PChar);
  88.     property Category: Byte read GetCategory;
  89.     property ErrorCode: DBIResult read FErrorCode;
  90.     property SubCode: Byte read GetSubCode;
  91.     property Message: string read FMessage;
  92.     property NativeError: Longint read FNativeError;
  93.   end;
  94.  
  95. { TLocale }
  96.  
  97.   TLocale = Pointer;
  98.  
  99. { TBDECallback }
  100.  
  101.   TBDECallbackEvent = function(CBInfo: Pointer): CBRType of Object;
  102.  
  103.   TBDECallback = class
  104.   private
  105.     FHandle: hDBICur;
  106.     FOwner: TObject;
  107.     FCBType: CBType;
  108.     FOldCBData: Longint;
  109.     FOldCBBuf: Pointer;
  110.     FOldCBBufLen: Word;
  111.     FOldCBFunc: pfDBICallBack;
  112.     FInstalled: Boolean;
  113.     FCallbackEvent: TBDECallbackEvent;
  114.   protected
  115.     function Invoke(CallType: CBType; CBInfo: Pointer): CBRType;
  116.   public
  117.     constructor Create(AOwner: TObject; Handle: hDBICur; CBType: CBType;
  118.       CBBuf: Pointer; CBBufSize: Integer; CallbackEvent: TBDECallbackEvent;
  119.       Chain: Boolean);
  120.     destructor Destroy; override;
  121.   end;
  122.  
  123. { TSessionList }
  124.  
  125.   TSessionList = class(TObject)
  126.   private
  127.     FSessions: TList; { ! Use TThreadList here }
  128.     FSessionNumbers: TBits;
  129.     procedure AddSession(ASession: TSession);
  130.     procedure CloseAll;
  131.     function GetCount: Integer;
  132.     function GetSession(Index: Integer): TSession;
  133.     function GetCurrentSession: TSession;
  134.     function GetSessionByName(const SessionName: string): TSession;
  135.     procedure SetCurrentSession(Value: TSession);
  136.   public
  137.     constructor Create;
  138.     destructor Destroy; override;
  139.     property CurrentSession: TSession read GetCurrentSession write SetCurrentSession;
  140.     function FindSession(const SessionName: string): TSession;
  141.     procedure GetSessionNames(List: TStrings);
  142.     function OpenSession(const SessionName: string): TSession;
  143.     property Count: Integer read GetCount;
  144.     property Sessions[Index: Integer]: TSession read GetSession; default;
  145.     property List[const SessionName: string]: TSession read GetSessionByName;
  146.   end;
  147.  
  148. { TSession }
  149.  
  150.   TConfigModes = (cfmVirtual, cfmPersistent, cfmSession);
  151.   TConfigMode = set of TConfigModes;
  152.  
  153.   TPasswordEvent = procedure(Sender: TObject; var Continue: Boolean) of Object;
  154.  
  155.   TDatabaseEvent = (dbOpen, dbClose, dbAdd, dbRemove, dbAddAlias, dbDeleteAlias,
  156.     dbAddDriver, dbDeleteDriver);
  157.  
  158.   TDatabaseNotifyEvent = procedure(DBEvent: TDatabaseEvent; const Param) of object;
  159.  
  160.   TBDEInitProc = procedure(Session: TSession);
  161.  
  162.   TTraceFlag = (tfQPrepare, tfQExecute, tfError, tfStmt, tfConnect,
  163.     tfTransact, tfBlob, tfMisc, tfVendor, tfDataIn, tfDataOut);
  164.  
  165.   TTraceFlags = set of TTraceFlag;
  166.  
  167.   TSession = class(TComponent)
  168.   private
  169.     FHandle: HDBISes;
  170.     FDatabases: TList;
  171.     FCallbacks: TList;
  172.     FLocale: TLocale;
  173.     FTraceFlags: TTraceFlags;
  174.     FSMClient: ISMClient;
  175.     FSMBuffer: PTraceDesc;
  176.     FSMLoadFailed: Boolean;
  177.     FStreamedActive: Boolean;
  178.     FStreamedAutoSessionName: Boolean;
  179.     FKeepConnections: Boolean;
  180.     FDefault: Boolean;
  181.     FSQLHourGlass: Boolean;
  182.     FAutoSessionName: Boolean;
  183.     FSessionName: string;
  184.     FSessionNumber: Integer;
  185.     FUpdatingAutoSessionName: Boolean;
  186.     FNetFileDir: string;
  187.     FPrivateDir: string;
  188.     FCBSCType: CBSCType;
  189.     FDLLDetach: Boolean;
  190.     FBDEOwnsLoginCbDb: Boolean;
  191.     FLockCount: Integer;
  192.     FCBDBLogin: TCBDBLogin;
  193.     FOnPassword: TPasswordEvent;
  194.     FOnStartup: TNotifyEvent;
  195.     FOnDBNotify: TDatabaseNotifyEvent;
  196.     procedure AddDatabase(Value: TDatabase);
  197.     procedure CallBDEInitProcs;
  198.     procedure CheckInactive;
  199.     procedure CheckConfigMode(CfgMode: TConfigMode);
  200.     function DBLoginCallback(CBInfo: Pointer): CBRType;
  201.     procedure DBNotification(DBEvent: TDatabaseEvent; const Param);
  202.     procedure DeleteConfigPath(const Path, Node: string);
  203.     function GetActive: Boolean;
  204.     function GetConfigMode: TConfigMode;
  205.     function GetDatabase(Index: Integer): TDatabase;
  206.     function GetDatabaseCount: Integer;
  207.     function GetHandle: HDBISes;
  208.     function GetNetFileDir: string;
  209.     function GetPrivateDir: string;
  210.     procedure InitializeBDE;
  211.     procedure InternalAddAlias(const Name, Driver: string; List: TStrings;
  212.       CfgMode: TConfigMode; RestoreMode: Boolean);
  213.     procedure InternalDeleteAlias(const Name: string; CfgMode: TConfigMode;
  214.       RestoreMode: Boolean);
  215.     function SessionNameStored: Boolean;
  216.     procedure LoadSMClient;
  217.     procedure LockSession;
  218.     procedure MakeCurrent;
  219.     procedure RegisterCallbacks(Value: Boolean);
  220.     procedure RemoveDatabase(Value: TDatabase);
  221.     function ServerCallback(CBInfo: Pointer): CBRType;
  222.     procedure SetActive(Value: Boolean);
  223.     procedure SetAutoSessionName(Value: Boolean);
  224.     procedure SetConfigMode(Value: TConfigMode);
  225.     procedure SetConfigParams(const Path, Node: string; List: TStrings);
  226.     procedure SetNetFileDir(const Value: string);
  227.     procedure SetPrivateDir(const Value: string);
  228.     procedure SetSessionName(const Value: string);
  229.     procedure SetSessionNames;
  230.     procedure SetTraceFlags(Value: TTraceFlags);
  231.     procedure SMClientSignal(Sender: TObject; Data: Integer);
  232.     function SqlTraceCallback(CBInfo: Pointer): CBRType;
  233.     procedure StartSession(Value: Boolean);
  234.     procedure UnlockSession;
  235.     procedure UpdateAutoSessionName;
  236.     procedure ValidateAutoSession(AOwner: TComponent; AllSessions: Boolean);
  237.   protected
  238.     procedure Loaded; override;
  239.     procedure ModifyConfigParams(const Path, Node: string; List: TStrings);
  240.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  241.     property OnDBNotify: TDatabaseNotifyEvent read FOnDBNotify write FOnDBNotify;
  242.     property BDEOwnsLoginCbDb: Boolean read FBDEOwnsLoginCbDb write FBDEOwnsLoginCbDb;
  243.     procedure SetName(const NewName: TComponentName); override;
  244.   public
  245.     constructor Create(AOwner: TComponent); override;
  246.     destructor Destroy; override;
  247.     procedure AddAlias(const Name, Driver: string; List: TStrings);
  248.     procedure AddDriver(const Name: string; List: TStrings);
  249.     procedure AddStandardAlias(const Name, Path, DefaultDriver: string);
  250.     property ConfigMode: TConfigMode read GetConfigMode write SetConfigMode;
  251.     procedure AddPassword(const Password: string);
  252.     procedure Close;
  253.     procedure CloseDatabase(Database: TDatabase);
  254.     procedure DeleteAlias(const Name: string);
  255.     procedure DeleteDriver(const Name: string);
  256.     procedure DropConnections;
  257.     function FindDatabase(const DatabaseName: string): TDatabase;
  258.     procedure GetAliasNames(List: TStrings);
  259.     procedure GetAliasParams(const AliasName: string; List: TStrings);
  260.     function GetAliasDriverName(const AliasName: string): string;
  261.     procedure GetConfigParams(const Path, Section: string; List: TStrings);
  262.     procedure GetDatabaseNames(List: TStrings);
  263.     procedure GetDriverNames(List: TStrings);
  264.     procedure GetDriverParams(const DriverName: string; List: TStrings);
  265.     function GetPassword: Boolean;
  266.     procedure GetTableNames(const DatabaseName, Pattern: string;
  267.       Extensions, SystemTables: Boolean; List: TStrings);
  268.     procedure GetStoredProcNames(const DatabaseName: string; List: TStrings);
  269.     function IsAlias(const Name: string): Boolean;
  270.     procedure ModifyAlias(Name: string; List: TStrings);
  271.     procedure ModifyDriver(Name: string; List: TStrings);
  272.     procedure Open;
  273.     function OpenDatabase(const DatabaseName: string): TDatabase;
  274.     procedure RemoveAllPasswords;
  275.     procedure RemovePassword(const Password: string);
  276.     procedure SaveConfigFile;
  277.     property DatabaseCount: Integer read GetDatabaseCount;
  278.     property Databases[Index: Integer]: TDatabase read GetDatabase;
  279.     property Handle: HDBISES read GetHandle;
  280.     property Locale: TLocale read FLocale;
  281.     property TraceFlags: TTraceFlags read FTraceFlags write SetTraceFlags;
  282.   published
  283.     property Active: Boolean read GetActive write SetActive default False;
  284.     property AutoSessionName: Boolean read FAutoSessionName write SetAutoSessionName default False;
  285.     property KeepConnections: Boolean read FKeepConnections write FKeepConnections default True;
  286.     property NetFileDir: string read GetNetFileDir write SetNetFileDir;
  287.     property PrivateDir: string read GetPrivateDir write SetPrivateDir;
  288.     property SessionName: string read FSessionName write SetSessionName stored SessionNameStored;
  289.     property SQLHourGlass: Boolean read FSQLHourGlass write FSQLHourGlass default True;
  290.     property OnPassword: TPasswordEvent read FOnPassword write FOnPassword;
  291.     property OnStartup: TNotifyEvent read FOnStartup write FOnStartup;
  292.   end;
  293.  
  294. { TParamList }
  295.  
  296.   TParamList = class(TObject)
  297.   private
  298.     FFieldCount: Integer;
  299.     FBufSize: Word;
  300.     FFieldDescs: PFieldDescList;
  301.     FBuffer: PChar;
  302.   public
  303.     constructor Create(Params: TStrings);
  304.     destructor Destroy; override;
  305.     property Buffer: PChar read FBuffer;
  306.     property FieldCount: Integer read FFieldCount;
  307.     property FieldDescs: PFieldDescList read FFieldDescs;
  308.   end;
  309.  
  310. { TDatabase }
  311.  
  312.   TTransIsolation = (tiDirtyRead, tiReadCommitted, tiRepeatableRead);
  313.  
  314.   TLoginEvent = procedure(Database: TDatabase;
  315.     LoginParams: TStrings) of object;
  316.  
  317.   TDatabase = class(TComponent)
  318.   private
  319.     FDataSets: TList;
  320.     FTransIsolation: TTransIsolation;
  321.     FLoginPrompt: Boolean;
  322.     FKeepConnection: Boolean;
  323.     FTemporary: Boolean;
  324.     FSessionAlias: Boolean;
  325.     FStreamedConnected: Boolean;
  326.     FLocaleLoaded: Boolean;
  327.     FAliased: Boolean;
  328.     FRefCount: Integer;
  329.     FHandle: HDBIDB;
  330.     FSQLBased: Boolean;
  331.     FLocale: TLocale;
  332.     FSession: TSession;
  333.     FSessionName: string;
  334.     FParams: TStrings;
  335.     FDatabaseName: string;
  336.     FDatabaseType: string;
  337.     FAcquiredHandle: Boolean;
  338.     FOnLogin: TLoginEvent;
  339.     procedure CheckActive;
  340.     procedure CheckInactive;
  341.     procedure CheckDatabaseName;
  342.     procedure CheckDatabaseAlias(var Password: string);
  343.     procedure CheckSessionName(Required: Boolean);
  344.     procedure EndTransaction(TransEnd: EXEnd);
  345.     function GetAliasName: string;
  346.     function GetConnected: Boolean;
  347.     function GetDataSet(Index: Integer): TDBDataSet;
  348.     function GetDataSetCount: Integer;
  349.     function GetDirectory: string;
  350.     function GetDriverName: string;
  351.     function GetIsSQLBased: Boolean;
  352.     function GetInTransaction: Boolean;
  353.     function GetTraceFlags: TTraceFlags;
  354.     procedure LoadLocale;
  355.     procedure Login(LoginParams: TStrings);
  356.     procedure ParamsChanging(Sender: TObject);
  357.     procedure SetAliasName(const Value: string);
  358.     procedure SetConnected(Value: Boolean);
  359.     procedure SetDatabaseName(const Value: string);
  360.     procedure SetDatabaseType(const Value: string; Aliased: Boolean);
  361.     procedure SetDirectory(const Value: string);
  362.     procedure SetDriverName(const Value: string);
  363.     procedure SetHandle(Value: HDBIDB);
  364.     procedure SetKeepConnection(Value: Boolean);
  365.     procedure SetParams(Value: TStrings);
  366.     procedure SetTraceFlags(Value: TTraceFlags);
  367.     procedure SetSessionName(const Value: string);
  368.   protected
  369.     procedure Loaded; override;
  370.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  371.   public
  372.     constructor Create(AOwner: TComponent); override;
  373.     destructor Destroy; override;
  374.     procedure ApplyUpdates(const DataSets: array of TDBDataSet);
  375.     procedure Close;
  376.     procedure CloseDataSets;
  377.     procedure Commit;
  378.     procedure FlushSchemaCache(const TableName: string);
  379.     procedure Open;
  380.     procedure Rollback;
  381.     procedure StartTransaction;
  382.     procedure ValidateName(const Name: string);
  383.     property DataSetCount: Integer read GetDataSetCount;
  384.     property DataSets[Index: Integer]: TDBDataSet read GetDataSet;
  385.     property Directory: string read GetDirectory write SetDirectory;
  386.     property Handle: HDBIDB read FHandle write SetHandle;
  387.     property IsSQLBased: Boolean read FSQLBased;
  388.     property InTransaction: Boolean read GetInTransaction;
  389.     property Locale: TLocale read FLocale;
  390.     property Session: TSession read FSession;
  391.     property Temporary: Boolean read FTemporary write FTemporary;
  392.     property SessionAlias: Boolean read FSessionAlias;
  393.     property TraceFlags: TTraceFlags read GetTraceFlags write SetTraceFlags;
  394.   published
  395.     property AliasName: string read GetAliasName write SetAliasName;
  396.     property Connected: Boolean read GetConnected write SetConnected default False;
  397.     property DatabaseName: string read FDatabaseName write SetDatabaseName;
  398.     property DriverName: string read GetDriverName write SetDriverName;
  399.     property KeepConnection: Boolean read FKeepConnection write SetKeepConnection default True;
  400.     property LoginPrompt: Boolean read FLoginPrompt write FLoginPrompt default True;
  401.     property Params: TStrings read FParams write SetParams;
  402.     property SessionName: string read FSessionName write SetSessionName;
  403.     property TransIsolation: TTransIsolation read FTransIsolation write FTransIsolation default tiReadCommitted;
  404.     property OnLogin: TLoginEvent read FOnLogin write FOnLogin;
  405.   end;
  406.  
  407. { TBDEDataSet }
  408.  
  409.   TRecNoStatus = (rnDbase, rnParadox, rnNotSupported);
  410.   TUpdateAction = (uaFail, uaAbort, uaSkip, uaRetry, uaApplied);
  411.   TUpdateRecordTypes = set of (rtModified, rtInserted, rtDeleted, rtUnmodified);
  412.   TUpdateErrorEvent = procedure(DataSet: TDataSet; E: EDatabaseError;
  413.     UpdateKind: TUpdateKind; var UpdateAction: TUpdateAction) of object;
  414.   TUpdateRecordEvent = procedure(DataSet: TDataSet; UpdateKind: TUpdateKind;
  415.     var UpdateAction: TUpdateAction) of object;
  416.   TOnServerYieldEvent = procedure(DataSet: TDataSet; var AbortQuery: Boolean) of object;
  417.   TDataSetUpdateObject = class(TComponent)
  418.   protected
  419.     function GetDataSet: TBDEDataSet; virtual; abstract;
  420.     procedure SetDataSet(ADataSet: TBDEDataSet); virtual; abstract;
  421.     procedure Apply(UpdateKind: TUpdateKind); virtual; abstract;
  422.     property DataSet: TBDEDataSet read GetDataSet write SetDataSet;
  423.   end;
  424.  
  425.   TKeyIndex = (kiLookup, kiRangeStart, kiRangeEnd, kiCurRangeStart,
  426.     kiCurRangeEnd, kiSave);
  427.  
  428.   PKeyBuffer = ^TKeyBuffer;
  429.   TKeyBuffer = record
  430.     Modified: Boolean;
  431.     Exclusive: Boolean;
  432.     FieldCount: Integer;
  433.     Data: record end;
  434.   end;
  435.  
  436.   PRecInfo = ^TRecInfo;
  437.   TRecInfo = record
  438.     RecordNumber: Longint;
  439.     UpdateStatus: TUpdateStatus;
  440.     BookmarkFlag: TBookmarkFlag;
  441.   end;
  442.  
  443.   TBlobData = string;
  444.   TBlobDataArray = array[0..0] of TBlobData;
  445.   PBlobDataArray = ^TBlobDataArray;
  446.  
  447.   TBDEDataSet = class(TDataSet)
  448.   private
  449.     FHandle: HDBICur;
  450.     FRecProps: RecProps;
  451.     FLocale: TLocale;
  452.     FExprFilter: HDBIFilter;
  453.     FFuncFilter: HDBIFilter;
  454.     FFilterBuffer: PChar;
  455.     FIndexFieldMap: DBIKey;
  456.     FExpIndex: Boolean;
  457.     FCaseInsIndex: Boolean;
  458.     FCachedUpdates: Boolean;
  459.     FInUpdateCallback: Boolean;
  460.     FCanModify: Boolean;
  461.     FCacheBlobs: Boolean;
  462.     FKeySize: Word;
  463.     FUpdateCBBuf: PDELAYUPDCbDesc;
  464.     FUpdateCallback: TBDECallback;
  465.     FAsyncCallback: TBDECallback;
  466.     FCBYieldStep: CBYieldStep;
  467.     FKeyBuffers: array[TKeyIndex] of PKeyBuffer;
  468.     FKeyBuffer: PKeyBuffer;
  469.     FRecNoStatus: TRecNoStatus;
  470.     FIndexFieldCount: Integer;
  471.     FConstDisableCount: Integer;
  472.     FConstraintsDB: HDBIDB;
  473.     FRecordSize: Word;
  474.     FBookmarkOfs: Word;
  475.     FRecInfoOfs: Word;
  476.     FBlobCacheOfs: Word;
  477.     FRecBufSize: Word;
  478.     FProvIntf: IProvider;
  479.     FOnServerYield: TOnServerYieldEvent;
  480.     FUpdateObject: TDataSetUpdateObject;
  481.     FOnUpdateError: TUpdateErrorEvent;
  482.     FOnUpdateRecord: TUpdateRecordEvent;
  483.     procedure ClearBlobCache(Buffer: PChar);
  484.     function GetActiveRecBuf(var RecBuf: PChar): Boolean;
  485.     function GetBlobData(Field: TField; Buffer: PChar): TBlobData;
  486.     function GetOldRecord: PChar;
  487.     procedure InitBufferPointers(GetProps: Boolean);
  488.     function RecordFilter(RecBuf: Pointer; RecNo: Integer): Smallint; stdcall;
  489.     procedure SetBlobData(Field: TField; Buffer: PChar; Value: TBlobData);
  490.     function HasConstraints: Boolean;
  491.   protected
  492.     procedure ActivateFilters;
  493.     procedure AddFieldDesc(FieldDesc: FLDDesc; Required: Boolean; FieldNo: Word);
  494.     procedure AllocCachedUpdateBuffers(Allocate: Boolean);
  495.     procedure AllocKeyBuffers;
  496.     function AllocRecordBuffer: PChar; override;
  497.     function BCDToCurr(BCD: Pointer; var Curr: Currency): Boolean; override;
  498.     function CurrToBCD(const Curr: Currency; BCD: Pointer; Precision,
  499.       Decimals: Integer): Boolean; override;
  500.     function CachedUpdateCallBack(CBInfo: Pointer): CBRType;
  501.     procedure CheckCachedUpdateMode;
  502.     procedure CheckSetKeyMode;
  503.     procedure ClearCalcFields(Buffer: PChar); override;
  504.     procedure CloseCursor; override;
  505.     procedure CloseBlob(Field: TField); override;
  506.     function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
  507.     function CreateExprFilter(const Expr: string;
  508.       Options: TFilterOptions; Priority: Integer): HDBIFilter;
  509.     function CreateFuncFilter(FilterFunc: Pointer;
  510.       Priority: Integer): HDBIFilter;
  511.     function CreateHandle: HDBICur; virtual;
  512.     function CreateLookupFilter(Fields: TList; const Values: Variant;
  513.       Options: TLocateOptions; Priority: Integer): HDBIFilter;
  514.     procedure DeactivateFilters;
  515.     procedure DestroyHandle; virtual;
  516.     procedure DestroyLookupCursor; virtual;
  517.     function FindRecord(Restart, GoForward: Boolean): Boolean; override;
  518.     function ForceUpdateCallback: Boolean;
  519.     procedure FreeKeyBuffers;
  520.     procedure FreeRecordBuffer(var Buffer: PChar); override;
  521.     procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
  522.     function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
  523.     function GetCanModify: Boolean; override;
  524.     function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
  525.     function GetIndexField(Index: Integer): TField;
  526.     function GetIndexFieldCount: Integer;
  527.     function GetIsIndexField(Field: TField): Boolean; override;
  528.     function GetKeyBuffer(KeyIndex: TKeyIndex): PKeyBuffer;
  529.     function GetKeyExclusive: Boolean;
  530.     function GetKeyFieldCount: Integer;
  531.     function GetLookupCursor(const KeyFields: string;
  532.       CaseInsensitive: Boolean): HDBICur; virtual;
  533.     function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override;
  534.     function GetRecordCount: Integer; override;
  535.     function GetRecNo: Integer; override;
  536.     function GetRecordSize: Word; override;
  537.     function GetStateFieldValue(State: TDataSetState; Field: TField): Variant; override;
  538.     function GetUpdatesPending: Boolean;
  539.     function GetUpdateRecordSet: TUpdateRecordTypes;
  540.     function InitKeyBuffer(Buffer: PKeyBuffer): PKeyBuffer;
  541.     procedure InitRecord(Buffer: PChar); override;
  542.     procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
  543.     procedure InternalCancel; override;
  544.     procedure InternalClose; override;
  545.     procedure InternalDelete; override;
  546.     procedure InternalEdit; override;
  547.     procedure InternalFirst; override;
  548.     procedure InternalGotoBookmark(Bookmark: TBookmark); override;
  549.     procedure InternalHandleException; override;
  550.     procedure InternalInitFieldDefs; override;
  551.     procedure InternalInitRecord(Buffer: PChar); override;
  552.     procedure InternalLast; override;
  553.     procedure InternalOpen; override;
  554.     procedure InternalPost; override;
  555.     procedure InternalRefresh; override;
  556.     procedure InternalSetToRecord(Buffer: PChar); override;
  557.     function IsCursorOpen: Boolean; override;
  558.     function LocateRecord(const KeyFields: string; const KeyValues: Variant;
  559.       Options: TLocateOptions; SyncCursor: Boolean): Boolean;
  560.     function MapsToIndex(Fields: TList; CaseInsensitive: Boolean): Boolean;
  561.     procedure OpenCursor(InfoQuery: Boolean); override;
  562.     procedure Post; override;
  563.     procedure PostKeyBuffer(Commit: Boolean);
  564.     procedure PrepareCursor; virtual;
  565.     function ProcessUpdates(UpdCmd: DBIDelayedUpdCmd): DBIResult;
  566.     function ResetCursorRange: Boolean;
  567.     procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
  568.     procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
  569.     procedure SetCachedUpdates(Value: Boolean);
  570.     function SetCursorRange: Boolean;
  571.     procedure SetFieldData(Field: TField; Buffer: Pointer); override;
  572.     procedure SetFilterData(const Text: string; Options: TFilterOptions);
  573.     procedure SetFilterHandle(var Filter: HDBIFilter; Value: HDBIFilter);
  574.     procedure SetFiltered(Value: Boolean); override;
  575.     procedure SetFilterOptions(Value: TFilterOptions); override;
  576.     procedure SetFilterText(const Value: string); override;
  577.     procedure SetIndexField(Index: Integer; Value: TField);
  578.     procedure SetKeyBuffer(KeyIndex: TKeyIndex; Clear: Boolean);
  579.     procedure SetKeyExclusive(Value: Boolean);
  580.     procedure SetKeyFieldCount(Value: Integer);
  581.     procedure SetKeyFields(KeyIndex: TKeyIndex; const Values: array of const);
  582.     procedure SetLinkRanges(MasterFields: TList);
  583.     procedure SetLocale(Value: TLocale);
  584.     procedure SetStateFieldValue(State: TDataSetState; Field: TField; Value: Variant); override;
  585.     procedure SetOnFilterRecord(const Value: TFilterRecordEvent); override;
  586.     procedure SetOnUpdateError(UpdateEvent: TUpdateErrorEvent);
  587.     procedure SetupCallBack(Value: Boolean);
  588.     procedure SetUpdateRecordSet(RecordTypes: TUpdateRecordTypes);
  589.     procedure SetUpdateObject(Value: TDataSetUpdateObject);
  590.     procedure SwitchToIndex(const IndexName, TagName: string);
  591.     procedure Translate(Src, Dest: PChar; ToOem: Boolean);  override;
  592.     function UpdateCallbackRequired: Boolean;
  593.     function YieldCallBack(CBInfo: Pointer): CBRType;
  594.   public
  595.     constructor Create(AOwner: TComponent); override;
  596.     destructor Destroy; override;
  597.     procedure ApplyUpdates;
  598.     function BookmarkValid(Bookmark: TBookmark): Boolean; override;
  599.     procedure Cancel; override;
  600.     procedure CancelUpdates;
  601.     property CacheBlobs: Boolean read FCacheBlobs write FCacheBlobs default True;
  602.     function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; override;
  603.     procedure CommitUpdates;
  604.     { ! This needs to move into the private section }
  605.     function ConstraintCallBack(Req: DsInfoReq; var ADataSources: DataSources): DBIResult; stdcall;
  606.     procedure DisableConstraints;
  607.     procedure EnableConstraints;
  608.     procedure FetchAll;
  609.     function GetCurrentRecord(Buffer: PChar): Boolean; override;
  610.     procedure GetIndexInfo;
  611.     function Locate(const KeyFields: string; const KeyValues: Variant;
  612.       Options: TLocateOptions): Boolean; override;
  613.     function Lookup(const KeyFields: string; const KeyValues: Variant;
  614.       const ResultFields: string): Variant; override;
  615.     procedure RevertRecord;
  616.     function UpdateStatus: TUpdateStatus;
  617.  
  618.     property ExpIndex: Boolean read FExpIndex;
  619.     property Handle: HDBICur read FHandle;
  620.     property KeySize: Word read FKeySize;
  621.     property Locale: TLocale read FLocale;
  622.     property UpdateObject: TDataSetUpdateObject read FUpdateObject write SetUpdateObject;
  623.     property UpdatesPending: Boolean read GetUpdatesPending;
  624.     property UpdateRecordTypes: TUpdateRecordTypes read GetUpdateRecordSet write SetUpdateRecordSet;
  625.   published
  626.     property Active;
  627.     property AutoCalcFields;
  628.     property CachedUpdates: Boolean read FCachedUpdates write SetCachedUpdates default False;
  629.     property Filter;
  630.     property Filtered;
  631.     property FilterOptions;
  632.     property BeforeOpen;
  633.     property AfterOpen;
  634.     property BeforeClose;
  635.     property AfterClose;
  636.     property BeforeInsert;
  637.     property AfterInsert;
  638.     property BeforeEdit;
  639.     property AfterEdit;
  640.     property BeforePost;
  641.     property AfterPost;
  642.     property BeforeCancel;
  643.     property AfterCancel;
  644.     property BeforeDelete;
  645.     property AfterDelete;
  646.     property BeforeScroll;
  647.     property AfterScroll;
  648.     property OnCalcFields;
  649.     property OnDeleteError;
  650.     property OnEditError;
  651.     property OnFilterRecord;
  652.     property OnNewRecord;
  653.     property OnPostError;
  654.     property OnServerYield: TOnServerYieldEvent read FOnServerYield write FOnServerYield;
  655.     property OnUpdateError: TUpdateErrorEvent read FOnUpdateError write SetOnUpdateError;
  656.     property OnUpdateRecord: TUpdateRecordEvent read FOnUpdateRecord write FOnUpdateRecord;
  657.   end;
  658.  
  659. { TDBDataSet }
  660.  
  661.   TUpdateMode = (upWhereAll, upWhereChanged, upWhereKeyOnly);
  662.   TDBFlags = set of 0..15;
  663.  
  664.   TDBDataSet = class(TBDEDataSet)
  665.   private
  666.     FDBFlags: TDBFlags;
  667.     FUpdateMode: TUpdateMode;
  668.     FDatabase: TDatabase;
  669.     FDatabaseName: string;
  670.     FSessionName: string;
  671.     procedure CheckDBSessionName;
  672.     function GetDBHandle: HDBIDB;
  673.     function GetDBLocale: TLocale;
  674.     function GetDBSession: TSession;
  675.     procedure SetDatabaseName(const Value: string);
  676.     procedure SetSessionName(const Value: string);
  677.     procedure SetUpdateMode(const Value: TUpdateMode);
  678.   protected
  679.     procedure CloseCursor; override;
  680.     function ConstraintsStored: Boolean;
  681.     procedure Disconnect; virtual;
  682.     function GetProvider: IProvider; virtual;
  683.     procedure OpenCursor(InfoQuery: Boolean); override;
  684.     procedure SetDBFlag(Flag: Integer; Value: Boolean); virtual;
  685.     property DBFlags: TDBFlags read FDBFlags;
  686.     property UpdateMode: TUpdateMode read FUpdateMode write SetUpdateMode default upWhereAll;
  687.   public
  688.     function CheckOpen(Status: DBIResult): Boolean;
  689.     property Database: TDatabase read FDatabase;
  690.     property DBHandle: HDBIDB read GetDBHandle;
  691.     property DBLocale: TLocale read GetDBLocale;
  692.     property DBSession: TSession read GetDBSession;
  693.     property Provider: IProvider read GetProvider;
  694.   published
  695.     property DatabaseName: string read FDatabaseName write SetDatabaseName;
  696.     property SessionName: string read FSessionName write SetSessionName;
  697.   end;
  698.  
  699. { TTable }
  700.  
  701.   TBatchMode = (batAppend, batUpdate, batAppendUpdate, batDelete, batCopy);
  702.   TTableType = (ttDefault, ttParadox, ttDBase, ttASCII);
  703.   TLockType = (ltReadLock, ltWriteLock);
  704.   TIndexName = type string;
  705.  
  706.   TIndexFiles = class(TStringList)
  707.   private
  708.     FOwner: TTable;
  709.   public
  710.     constructor Create(AOwner: TTable);
  711.     function Add(const S: string): Integer; override;
  712.     procedure Clear; override;
  713.     procedure Delete(Index: Integer); override;
  714.     procedure Insert(Index: Integer; const S: string); override;
  715.   end;
  716.  
  717.   TTable = class(TDBDataSet)
  718.   private
  719.     FIndexDefs: TIndexDefs;
  720.     FMasterLink: TMasterDataLink;
  721.     FExclusive: Boolean;
  722.     FReadOnly: Boolean;
  723.     FTableType: TTableType;
  724.     FFieldsIndex: Boolean;
  725.     FTableName: TFileName;
  726.     FIndexName: TIndexName;
  727.     FIndexFiles: TStrings;
  728.     FLookupHandle: HDBICur;
  729.     FLookupKeyFields: string;
  730.     FTableLevel: Integer;
  731.     FLookupCaseIns: Boolean;
  732.     procedure CheckMasterRange;
  733.     procedure DecodeIndexDesc(const IndexDesc: IDXDesc;
  734.       var Source, Name, Fields: string; var Options: TIndexOptions);
  735.     function GetDriverTypeName(Buffer: PChar): PChar;
  736.     function GetIndexFieldNames: string;
  737.     function GetIndexName: string;
  738.     procedure GetIndexParams(const IndexName: string; FieldsIndex: Boolean;
  739.       var IndexedName, IndexTag: string);
  740.     function GetMasterFields: string;
  741.     function GetTableTypeName: PChar;
  742.     function GetTableLevel: Integer;
  743.     function IsDBaseTable: Boolean;
  744.     procedure MasterChanged(Sender: TObject);
  745.     procedure MasterDisabled(Sender: TObject);
  746.     procedure SetDataSource(Value: TDataSource);
  747.     procedure SetExclusive(Value: Boolean);
  748.     procedure SetIndex(const Value: string; FieldsIndex: Boolean);
  749.     procedure SetIndexFieldNames(const Value: string);
  750.     procedure SetIndexFiles(Value: TStrings);
  751.     procedure SetIndexName(const Value: string);
  752.     procedure SetMasterFields(const Value: string);
  753.     procedure SetReadOnly(Value: Boolean);
  754.     procedure SetTableLock(LockType: TLockType; Lock: Boolean);
  755.     procedure SetTableName(const Value: TFileName);
  756.     procedure SetTableType(Value: TTableType);
  757.     function SetTempLocale(ActiveCheck: Boolean): TLocale;
  758.     procedure RestoreLocale(LocaleSave: TLocale);
  759.     procedure UpdateRange;
  760.   protected
  761.     function CreateHandle: HDBICur; override;
  762.     procedure DataEvent(Event: TDataEvent; Info: Longint); override;
  763.     procedure DestroyHandle; override;
  764.     procedure DestroyLookupCursor; override;
  765.     procedure DoOnNewRecord; override;
  766.     procedure EncodeFieldDesc(var FieldDesc: FLDDesc;
  767.       const Name: string; DataType: TFieldType; Size: Word);
  768.     procedure EncodeIndexDesc(var IndexDesc: IDXDesc;
  769.       const Name, Fields: string; Options: TIndexOptions);
  770.     function GetCanModify: Boolean; override;
  771.     function GetDataSource: TDataSource; override;
  772.     function GetHandle(const IndexName, IndexTag: string): HDBICur;
  773.     function GetLanguageDriverName: string;
  774.     function GetLookupCursor(const KeyFields: string;
  775.       CaseInsensitive: Boolean): HDBICur; override;
  776.     procedure InitFieldDefs; override;
  777.     function IsProductionIndex(const IndexName: string): Boolean;
  778.     procedure PrepareCursor; override;
  779.     procedure UpdateIndexDefs; override;
  780.   public
  781.     constructor Create(AOwner: TComponent); override;
  782.     destructor Destroy; override;
  783.     function BatchMove(ASource: TBDEDataSet; AMode: TBatchMode): Longint;
  784.     procedure AddIndex(const Name, Fields: string; Options: TIndexOptions);
  785.     procedure ApplyRange;
  786.     procedure CancelRange;
  787.     procedure CloseIndexFile(const IndexFileName: string);
  788.     procedure CreateTable;
  789.     procedure DeleteIndex(const Name: string);
  790.     procedure DeleteTable;
  791.     procedure EditKey;
  792.     procedure EditRangeEnd;
  793.     procedure EditRangeStart;
  794.     procedure EmptyTable;
  795.     function FindKey(const KeyValues: array of const): Boolean;
  796.     procedure FindNearest(const KeyValues: array of const);
  797.     procedure GetIndexNames(List: TStrings);
  798.     procedure GotoCurrent(Table: TTable);
  799.     function GotoKey: Boolean;
  800.     procedure GotoNearest;
  801.     procedure LockTable(LockType: TLockType);
  802.     procedure OpenIndexFile(const IndexName: string);
  803.     procedure RenameTable(const NewTableName: string);
  804.     procedure SetKey;
  805.     procedure SetRange(const StartValues, EndValues: array of const);
  806.     procedure SetRangeEnd;
  807.     procedure SetRangeStart;
  808.     procedure UnlockTable(LockType: TLockType);
  809.     property IndexDefs: TIndexDefs read FIndexDefs;
  810.     property IndexFieldCount: Integer read GetIndexFieldCount;
  811.     property IndexFields[Index: Integer]: TField read GetIndexField write SetIndexField;
  812.     property KeyExclusive: Boolean read GetKeyExclusive write SetKeyExclusive;
  813.     property KeyFieldCount: Integer read GetKeyFieldCount write SetKeyFieldCount;
  814.     property TableLevel: Integer read GetTableLevel write FTableLevel;
  815.   published
  816.     property Constraints stored ConstraintsStored;
  817.     property Exclusive: Boolean read FExclusive write SetExclusive default False;
  818.     property IndexFieldNames: string read GetIndexFieldNames write SetIndexFieldNames;
  819.     property IndexFiles: TStrings read FIndexFiles write SetIndexFiles;
  820.     property IndexName: string read GetIndexName write SetIndexName;
  821.     property MasterFields: string read GetMasterFields write SetMasterFields;
  822.     property MasterSource: TDataSource read GetDataSource write SetDataSource;
  823.     property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
  824.     property TableName: TFileName read FTableName write SetTableName;
  825.     property TableType: TTableType read FTableType write SetTableType default ttDefault;
  826.     property UpdateMode;
  827.     property UpdateObject;
  828.   end;
  829.  
  830. { TBatchMove }
  831.  
  832.   TBatchMove = class(TComponent)
  833.   private
  834.     FDestination: TTable;
  835.     FSource: TBDEDataSet;
  836.     FMode: TBatchMode;
  837.     FAbortOnKeyViol: Boolean;
  838.     FAbortOnProblem: Boolean;
  839.     FTransliterate: Boolean;
  840.     FRecordCount: Longint;
  841.     FMovedCount: Longint;
  842.     FKeyViolCount: Longint;
  843.     FProblemCount: Longint;
  844.     FChangedCount: Longint;
  845.     FMappings: TStrings;
  846.     FKeyViolTableName: TFileName;
  847.     FProblemTableName: TFileName;
  848.     FChangedTableName: TFileName;
  849.     FCommitCount: Integer;
  850.     function ConvertName(const Name: string; Buffer: PChar): PChar;
  851.     procedure SetMappings(Value: TStrings);
  852.     procedure SetSource(Value: TBDEDataSet);
  853.   protected
  854.     procedure Notification(AComponent: TComponent;
  855.       Operation: TOperation); override;
  856.   public
  857.     constructor Create(AOwner: TComponent); override;
  858.     destructor Destroy; override;
  859.     procedure Execute;
  860.   public
  861.     property ChangedCount: Longint read FChangedCount;
  862.     property KeyViolCount: Longint read FKeyViolCount;
  863.     property MovedCount: Longint read FMovedCount;
  864.     property ProblemCount: Longint read FProblemCount;
  865.   published
  866.     property AbortOnKeyViol: Boolean read FAbortOnKeyViol write FAbortOnKeyViol default True;
  867.     property AbortOnProblem: Boolean read FAbortOnProblem write FAbortOnProblem default True;
  868.     property CommitCount: Integer read FCommitCount write FCommitCount default 0;
  869.     property ChangedTableName: TFileName read FChangedTableName write FChangedTableName;
  870.     property Destination: TTable read FDestination write FDestination;
  871.     property KeyViolTableName: TFileName read FKeyViolTableName write FKeyViolTableName;
  872.     property Mappings: TStrings read FMappings write SetMappings;
  873.     property Mode: TBatchMode read FMode write FMode default batAppend;
  874.     property ProblemTableName: TFileName read FProblemTableName write FProblemTableName;
  875.     property RecordCount: Longint read FRecordCount write FRecordCount default 0;
  876.     property Source: TBDEDataSet read FSource write SetSource;
  877.     property Transliterate: Boolean read FTransliterate write FTransliterate default True;
  878.   end;
  879.  
  880. { TParam }
  881.  
  882.   TQuery = class;
  883.   TParams = class;
  884.  
  885.   TParamType = (ptUnknown, ptInput, ptOutput, ptInputOutput, ptResult);
  886.  
  887.   TParam = class(TPersistent)
  888.   private
  889.     FParamList: TParams;
  890.     FData: Variant;
  891.     FNativeStr: string;
  892.     FName: string;
  893.     FDataType: TFieldType;
  894.     FNull: Boolean;
  895.     FBound: Boolean;
  896.     FParamType: TParamType;
  897.     procedure InitValue;
  898.   protected
  899.     procedure AssignParam(Param: TParam);
  900.     procedure AssignTo(Dest: TPersistent); override;
  901.     function GetAsBCD: Currency;
  902.     function GetAsBoolean: Boolean;
  903.     function GetAsDateTime: TDateTime;
  904.     function GetAsFloat: Double;
  905.     function GetAsInteger: Longint;
  906.     function GetAsMemo: string;
  907.     function GetAsString: string;
  908.     function GetAsVariant: Variant;
  909.     function IsEqual(Value: TParam): Boolean;
  910.     function RecBufDataSize: Integer;
  911.     procedure RecBufGetData(Buffer: Pointer; Locale: TLocale);
  912.     procedure SetAsBCD(Value: Currency);
  913.     procedure SetAsBlob(Value: TBlobData);
  914.     procedure SetAsBoolean(Value: Boolean);
  915.     procedure SetAsCurrency(Value: Double);
  916.     procedure SetAsDate(Value: TDateTime);
  917.     procedure SetAsDateTime(Value: TDateTime);
  918.     procedure SetAsFloat(Value: Double);
  919.     procedure SetAsInteger(Value: Longint);
  920.     procedure SetAsMemo(const Value: string);
  921.     procedure SetAsString(const Value: string);
  922.     procedure SetAsSmallInt(Value: LongInt);
  923.     procedure SetAsTime(Value: TDateTime);
  924.     procedure SetAsVariant(Value: Variant);
  925.     procedure SetAsWord(Value: LongInt);
  926.     procedure SetDataType(Value: TFieldType);
  927.     procedure SetText(const Value: string);
  928.   public
  929.     constructor Create(AParamList: TParams; AParamType: TParamType);
  930.     destructor Destroy; override;
  931.     procedure Assign(Source: TPersistent); override;
  932.     procedure AssignField(Field: TField);
  933.     procedure AssignFieldValue(Field: TField; const Value: Variant);
  934.     procedure Clear;
  935.     procedure GetData(Buffer: Pointer);
  936.     function GetDataSize: Integer;
  937.     procedure SetBlobData(Buffer: Pointer; Size: Integer);
  938.     procedure SetData(Buffer: Pointer);
  939.     property AsBCD: Currency read GetAsBCD write SetAsBCD;
  940.     property AsBlob: TBlobData read GetAsString write SetAsBlob;
  941.     property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean;
  942.     property AsCurrency: Double read GetAsFloat write SetAsCurrency;
  943.     property AsDate: TDateTime read GetAsDateTime write SetAsDate;
  944.     property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;
  945.     property AsFloat: Double read GetAsFloat write SetAsFloat;
  946.     property AsInteger: LongInt read GetAsInteger write SetAsInteger;
  947.     property AsSmallInt: LongInt read GetAsInteger write SetAsSmallInt;
  948.     property AsMemo: string read GetAsMemo write SetAsMemo;
  949.     property AsString: string read GetAsString write SetAsString;
  950.     property AsTime: TDateTime read GetAsDateTime write SetAsTime;
  951.     property AsWord: LongInt read GetAsInteger write SetAsWord;
  952.     property Bound: Boolean read FBound write FBound;
  953.     property DataType: TFieldType read FDataType write SetDataType;
  954.     property IsNull: Boolean read FNull;
  955.     property Name: string read FName write FName;
  956.     property ParamType: TParamType read FParamType write FParamType;
  957.     property Text: string read GetAsString write SetText;
  958.     property Value: Variant read GetAsVariant write SetAsVariant;
  959.   end;
  960.  
  961. { TParams }
  962.  
  963.   TParams = class(TPersistent)
  964.   private
  965.     FItems: TList;
  966.     function GetParam(Index: Word): TParam;
  967.     function GetParamValue(const ParamName: string): Variant;
  968.     function GetVersion: Word;
  969.     procedure ReadBinaryData(Stream: TStream);
  970.     procedure SetParamValue(const ParamName: string;
  971.       const Value: Variant);
  972.     procedure WriteBinaryData(Stream: TStream);
  973.   protected
  974.     procedure AssignTo(Dest: TPersistent); override;
  975.     procedure DefineProperties(Filer: TFiler); override;
  976.   public
  977.     constructor Create; virtual;
  978.     destructor Destroy; override;
  979.     procedure Assign(Source: TPersistent); override;
  980.     procedure AssignValues(Value: TParams);
  981.     procedure AddParam(Value: TParam);
  982.     procedure RemoveParam(Value: TParam);
  983.     function CreateParam(FldType: TFieldType; const ParamName: string;
  984.       ParamType: TParamType): TParam;
  985.     function Count: Integer;
  986.     procedure Clear;
  987.     procedure GetParamList(List: TList; const ParamNames: string);
  988.     function IsEqual(Value: TParams): Boolean;
  989.     function ParamByName(const Value: string): TParam;
  990.     property Items[Index: Word]: TParam read GetParam; default;
  991.     property ParamValues[const ParamName: string]: Variant read GetParamValue write SetParamValue;
  992.   end;
  993.  
  994. { TStoredProc }
  995.  
  996.   PServerDesc = ^TServerDesc;
  997.   TServerDesc = record
  998.     ParamName: string[DBIMAXSPNAMELEN];
  999.     BindType: TFieldType;
  1000.   end;
  1001.  
  1002.   TParamBindMode = (pbByName, pbByNumber);
  1003.  
  1004.   TStoredProc = class(TDBDataSet)
  1005.   private
  1006.     FStmtHandle: HDBIStmt;
  1007.     FProcName: string;
  1008.     FParams: TParams;
  1009.     FParamDesc: PChar;
  1010.     FRecordBuffer: PChar;
  1011.     FOverLoad: Word;
  1012.     FPrepared: Boolean;
  1013.     FQueryMode: Boolean;
  1014.     FServerDescs: PChar;
  1015.     FBindMode: TParamBindMode;
  1016.     procedure BindParams;
  1017.     function CheckServerParams: Boolean;
  1018.     function CreateCursor(GenHandle: Boolean): HDBICur;
  1019.     procedure CreateParamDesc;
  1020.     procedure FreeStatement;
  1021.     function GetCursor(GenHandle: Boolean): HDBICur;
  1022.     procedure PrepareProc;
  1023.     procedure SetParamsList(Value: TParams);
  1024.     procedure SetServerParams;
  1025.   protected
  1026.     function CreateHandle: HDBICur; override;
  1027.     procedure Disconnect; override;
  1028.     function GetParamsCount: Word;
  1029.     procedure SetDBFlag(Flag: Integer; Value: Boolean); override;
  1030.     procedure SetOverLoad(Value: Word);
  1031.     procedure SetProcName(const Value: string);
  1032.     procedure SetPrepared(Value: Boolean);
  1033.     procedure SetPrepare(Value: Boolean);
  1034.   public
  1035.     constructor Create(AOwner: TComponent); override;
  1036.     destructor Destroy; override;
  1037.     procedure CopyParams(Value: TParams);
  1038.     function DescriptionsAvailable: Boolean;
  1039.     procedure ExecProc;
  1040.     function ParamByName(const Value: string): TParam;
  1041.     procedure Prepare;
  1042.     procedure GetResults;
  1043.     procedure UnPrepare;
  1044.     property ParamCount: Word read GetParamsCount;
  1045.     property StmtHandle: HDBIStmt read FStmtHandle;
  1046.     property Prepared: Boolean read FPrepared write SetPrepare;
  1047.   published
  1048.     property StoredProcName: string read FProcName write SetProcName;
  1049.     property Overload: Word read FOverload write SetOverload default 0;
  1050.     property Params: TParams read FParams write SetParamsList;
  1051.     property ParamBindMode: TParamBindMode read FBindMode write FBindMode default pbByName;
  1052.     property UpdateObject;
  1053.   end;
  1054.  
  1055. { TQuery }
  1056.  
  1057.   TQuery = class(TDBDataSet)
  1058.   private
  1059.     FStmtHandle: HDBIStmt;
  1060.     FSQL: TStrings;
  1061.     FPrepared: Boolean;
  1062.     FParams: TParams;
  1063.     FText: string;
  1064.     FDataLink: TDataLink;
  1065.     FLocal: Boolean;
  1066.     FRowsAffected: Integer;
  1067.     FUniDirectional: Boolean;
  1068.     FRequestLive: Boolean;
  1069.     FSQLBinary: PChar;
  1070.     FConstrained: Boolean;
  1071.     FParamCheck: Boolean;
  1072.     function CreateCursor(GenHandle: Boolean): HDBICur;
  1073.     procedure CreateParams(List: TParams; const Value: PChar);
  1074.     procedure DefineProperties(Filer: TFiler); override;
  1075.     procedure FreeStatement;
  1076.     function GetQueryCursor(GenHandle: Boolean): HDBICur;
  1077.     procedure GetStatementHandle(SQLText: PChar);
  1078.     function GetRowsAffected: Integer;
  1079.     procedure PrepareSQL(Value: PChar);
  1080.     procedure QueryChanged(Sender: TObject);
  1081.     procedure ReadBinaryData(Stream: TStream);
  1082.     procedure RefreshParams;
  1083.     procedure SetDataSource(Value: TDataSource);
  1084.     procedure SetQuery(Value: TStrings);
  1085.     procedure SetParamsList(Value: TParams);
  1086.     procedure SetParams;
  1087.     procedure SetParamsFromCursor;
  1088.     procedure SetPrepared(Value: Boolean);
  1089.     procedure SetPrepare(Value: Boolean);
  1090.     procedure WriteBinaryData(Stream: TStream);
  1091.   protected
  1092.     function CreateHandle: HDBICur; override;
  1093.     procedure Disconnect; override;
  1094.     function GetDataSource: TDataSource; override;
  1095.     function GetParamsCount: Word;
  1096.     procedure SetDBFlag(Flag: Integer; Value: Boolean); override;
  1097.   public
  1098.     constructor Create(AOwner: TComponent); override;
  1099.     destructor Destroy; override;
  1100.     procedure ExecSQL;
  1101.     function ParamByName(const Value: string): TParam;
  1102.     procedure Prepare;
  1103.     procedure UnPrepare;
  1104.     property Prepared: Boolean read FPrepared write SetPrepare;
  1105.     property ParamCount: Word read GetParamsCount;
  1106.     property Local: Boolean read FLocal;
  1107.     property StmtHandle: HDBIStmt read FStmtHandle;
  1108.     property Text: string read FText;
  1109.     property RowsAffected: Integer read GetRowsAffected;
  1110.     property SQLBinary: PChar read FSQLBinary write FSQLBinary;
  1111.   published
  1112.     property Constrained: Boolean read FConstrained write FConstrained default False;
  1113.     property Constraints stored ConstraintsStored;
  1114.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  1115.     property Params: TParams read FParams write SetParamsList;
  1116.     property ParamCheck: Boolean read FParamCheck write FParamCheck default True;
  1117.     property RequestLive: Boolean read FRequestLive write FRequestLive default False;
  1118.     property SQL: TStrings read FSQL write SetQuery;
  1119.     property UniDirectional: Boolean read FUniDirectional write FUniDirectional default False;
  1120.     property UpdateMode;
  1121.     property UpdateObject;
  1122. end;
  1123.  
  1124. { TUpdateSQL }
  1125.  
  1126.   TUpdateSQL = class(TDataSetUpdateObject)
  1127.   private
  1128.     FDataSet: TBDEDataSet;
  1129.     FQueries: array[TUpdateKind] of TQuery;
  1130.     FSQLText: array[TUpdateKind] of TStrings;
  1131.     function GetQuery(UpdateKind: TUpdateKind): TQuery;
  1132.     function GetSQL(UpdateKind: TUpdateKind): TStrings;
  1133.     function GetSQLIndex(Index: Integer): TStrings;
  1134.     procedure SetSQL(UpdateKind: TUpdateKind; Value: TStrings);
  1135.     procedure SetSQLIndex(Index: Integer; Value: TStrings);
  1136.   protected
  1137.     function GetDataSet: TBDEDataSet; override;
  1138.     procedure SetDataSet(ADataSet: TBDEDataSet); override;
  1139.     procedure SQLChanged(Sender: TObject);
  1140.   public
  1141.     constructor Create(AOwner: TComponent); override;
  1142.     destructor Destroy; override;
  1143.     procedure Apply(UpdateKind: TUpdateKind); override;
  1144.     procedure ExecSQL(UpdateKind: TUpdateKind);
  1145.     procedure SetParams(UpdateKind: TUpdateKind);
  1146.     property DataSet;
  1147.     property Query[UpdateKind: TUpdateKind]: TQuery read GetQuery;
  1148.     property SQL[UpdateKind: TUpdateKind]: TStrings read GetSQL write SetSQL;
  1149.   published
  1150.     property ModifySQL: TStrings index 0 read GetSQLIndex write SetSQLIndex;
  1151.     property InsertSQL: TStrings index 1 read GetSQLIndex write SetSQLIndex;
  1152.     property DeleteSQL: TStrings index 2 read GetSQLIndex write SetSQLIndex;
  1153.   end;
  1154.  
  1155. { TBlobStream }
  1156.  
  1157.   TBlobStream = class(TStream)
  1158.   private
  1159.     FField: TBlobField;
  1160.     FDataSet: TBDEDataSet;
  1161.     FBuffer: PChar;
  1162.     FMode: TBlobStreamMode;
  1163.     FFieldNo: Integer;
  1164.     FOpened: Boolean;
  1165.     FModified: Boolean;
  1166.     FPosition: Longint;
  1167.     FBlobData: TBlobData;
  1168.     FCached: Boolean;
  1169.     FCacheSize: Longint;
  1170.     function GetBlobSize: Longint;
  1171.   public
  1172.     constructor Create(Field: TBlobField; Mode: TBlobStreamMode);
  1173.     destructor Destroy; override;
  1174.     function Read(var Buffer; Count: Longint): Longint; override;
  1175.     function Write(const Buffer; Count: Longint): Longint; override;
  1176.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  1177.     procedure Truncate;
  1178.   end;
  1179.  
  1180. function AnsiToNative(Locale: TLocale; const AnsiStr: string;
  1181.   NativeStr: PChar; MaxLen: Integer): PChar;
  1182. procedure NativeToAnsi(Locale: TLocale; NativeStr: PChar;
  1183.   var AnsiStr: string);
  1184. procedure AnsiToNativeBuf(Locale: TLocale; Source, Dest: PChar; Len: Integer);
  1185. procedure NativeToAnsiBuf(Locale: TLocale; Source, Dest: PChar; Len: Integer);
  1186.  
  1187. function NativeCompareStr(Locale: TLocale; const S1, S2: string; Len: Integer): Integer;
  1188. function NativeCompareStrBuf(Locale: TLocale; const S1, S2: PChar; Len: Integer): Integer;
  1189. function NativeCompareText(Locale: TLocale; const S1, S2: string; Len: Integer): Integer;
  1190. function NativeCompareTextBuf(Locale: TLocale; const S1, S2: PChar; Len: Integer): Integer;
  1191.  
  1192. procedure DbiError(ErrorCode: DBIResult);
  1193. procedure Check(Status: DBIResult);
  1194. procedure RegisterBDEInitProc(const InitProc: TBDEInitProc);
  1195.  
  1196. const
  1197.   { Backward compatibility for TConfigMode }
  1198.   cmVirtual = [cfmVirtual];
  1199.   cmPersistent = [cfmPersistent];
  1200.   cmSession = [cfmSession];
  1201.   cmAll = [cfmPersistent, cfmSession, cfmVirtual];
  1202.  
  1203. var
  1204.   Session: TSession;
  1205.   Sessions: TSessionList;
  1206.   CreateProviderProc: function(DataSet: TDBDataSet): IProvider = nil;
  1207.  
  1208. implementation
  1209.  
  1210. uses Forms, DBPWDlg, DBLogDlg, DBConsts, BDEConst, ActiveX;
  1211.  
  1212. var
  1213.   FCSect: TRTLCriticalSection; { ! Use TThreadList }
  1214.   StartTime: LongInt = 0;
  1215.   TimerID: Word;
  1216.   AcquiredTimer: Boolean = False;
  1217.   BDEInitProcs: TList;
  1218.  
  1219. { TQueryDataLink }
  1220.  
  1221. type
  1222.   TQueryDataLink = class(TDataLink)
  1223.   private
  1224.     FQuery: TQuery;
  1225.   protected
  1226.     procedure ActiveChanged; override;
  1227.     procedure RecordChanged(Field: TField); override;
  1228.     procedure CheckBrowseMode; override;
  1229.   public
  1230.     constructor Create(AQuery: TQuery);
  1231.   end;
  1232.  
  1233. { Utility routines }
  1234.  
  1235. function DefaultSession: TSession;
  1236. begin
  1237.   Result := DBTables.Session;
  1238. end;
  1239.  
  1240. procedure RegisterBDEInitProc(const InitProc: TBDEInitProc);
  1241. begin
  1242.   if not Assigned(BDEInitProcs) then
  1243.     BDEInitProcs := TList.Create;
  1244.   BDEInitProcs.Add(@InitProc);
  1245. end;
  1246.  
  1247. procedure FreeTimer;
  1248. begin
  1249.   if AcquiredTimer then
  1250.   begin
  1251.     KillTimer(0, TimerID);
  1252.     AcquiredTimer := False;
  1253.     StartTime := 0;
  1254.     Screen.Cursor := crDefault;
  1255.   end;
  1256. end;
  1257.  
  1258. procedure CheckIndexOpen(Status: DBIResult);
  1259. begin
  1260.   if (Status <> 0) and (Status <> DBIERR_INDEXOPEN) then
  1261.     DbiError(Status);
  1262. end;
  1263.  
  1264. { Timer callback function }
  1265.  
  1266. procedure TimerCallBack(hWnd: HWND; Message: Word; TimerID: Word;
  1267.   SysTime: LongInt); stdcall;
  1268. begin
  1269.   FreeTimer;
  1270. end;
  1271.  
  1272. { BdeCallbacks }
  1273.  
  1274. function BdeCallBack(CallType: CBType; Data: Longint;
  1275.   CBInfo: Pointer): CBRType; stdcall;
  1276. begin
  1277.   if (Data <> 0) then
  1278.     Result := TBDECallback(Data).Invoke(CallType, CBInfo) else
  1279.     Result := cbrUSEDEF;
  1280. end;
  1281.  
  1282. function DLLDetachCallBack(CallType: CBType; Data: Longint;
  1283.   CBInfo: Pointer): CBRType; stdcall;
  1284. begin
  1285.   Session.FDLLDetach := True;
  1286.   Sessions.CloseAll;
  1287.   Result := cbrUSEDEF
  1288. end;
  1289.  
  1290. constructor TBDECallback.Create(AOwner: TObject; Handle: hDBICur; CBType: CBType;
  1291.   CBBuf: Pointer; CBBufSize: Integer; CallbackEvent: TBDECallbackEvent;
  1292.   Chain: Boolean);
  1293. begin
  1294.   FOwner := AOwner;
  1295.   FHandle := Handle;
  1296.   FCBType := CBType;
  1297.   FCallbackEvent := CallbackEvent;
  1298.   DbiGetCallBack(Handle, FCBType, @FOldCBData, @FOldCBBufLen, @FOldCBBuf, FOldCBFunc);
  1299.   if not Assigned(FOldCBFunc) or Chain then
  1300.   begin
  1301.     Check(DbiRegisterCallback(FHandle, FCBType, Longint(Self), CBBufSize,
  1302.       CBBuf, BdeCallBack));
  1303.     FInstalled := True;
  1304.   end;
  1305. end;
  1306.  
  1307. destructor TBDECallback.Destroy;
  1308. begin
  1309.   if FInstalled then
  1310.   begin
  1311.     if Assigned(FOldCBFunc) then
  1312.     try
  1313.       DbiRegisterCallback(FHandle, FCBType, FOldCBData, FOldCBBufLen,
  1314.         FOldCBBuf, FOldCBFunc);
  1315.     except
  1316.     end
  1317.     else
  1318.       DbiRegisterCallback(FHandle, FCBType, 0, 0, nil, nil);
  1319.   end;
  1320. end;
  1321.  
  1322. function TBDECallback.Invoke(CallType: CBType; CBInfo: Pointer): CBRType;
  1323. begin
  1324.   if CallType = FCBType then
  1325.     Result := FCallbackEvent(CBInfo) else
  1326.     Result := cbrUSEDEF;
  1327.   if Assigned(FOldCBFunc)
  1328.     then Result := FOldCBFunc(CallType, FOldCBData, CBInfo);
  1329. end;
  1330.  
  1331. { Utility routines }
  1332.  
  1333. function StrToOem(const AnsiStr: string): string;
  1334. begin
  1335.   SetLength(Result, Length(AnsiStr));
  1336.   if Length(Result) > 0 then
  1337.     CharToOem(PChar(AnsiStr), PChar(Result));
  1338. end;
  1339.  
  1340. function AnsiToNative(Locale: TLocale; const AnsiStr: string;
  1341.   NativeStr: PChar; MaxLen: Integer): PChar;
  1342. var
  1343.   Len: Integer;
  1344. begin
  1345.   Len := Length(AnsiStr);
  1346.   if Len > MaxLen then Len := MaxLen;
  1347.   NativeStr[Len] := #0;
  1348.   if Len > 0 then AnsiToNativeBuf(Locale, Pointer(AnsiStr), NativeStr, Len);
  1349.   CharNext(AnsiStrLastChar(NativeStr))^ := #0;
  1350.   Result := NativeStr;
  1351. end;
  1352.  
  1353. procedure NativeToAnsi(Locale: TLocale; NativeStr: PChar;
  1354.   var AnsiStr: string);
  1355. var
  1356.   Len: Integer;
  1357. begin
  1358.   Len := StrLen(NativeStr);
  1359.   SetString(AnsiStr, nil, Len);
  1360.   if Len > 0 then NativeToAnsiBuf(Locale, NativeStr, Pointer(AnsiStr), Len);
  1361. end;
  1362.  
  1363. procedure AnsiToNativeBuf(Locale: TLocale; Source, Dest: PChar; Len: Integer);
  1364. var
  1365.   DataLoss: LongBool;
  1366. begin
  1367.   if Len > 0 then
  1368.     if Locale <> nil then
  1369.       DbiAnsiToNative(Locale, Dest, Source, Len, DataLoss) else
  1370.       CharToOemBuff(Source, Dest, Len);
  1371. end;
  1372.  
  1373. procedure NativeToAnsiBuf(Locale: TLocale; Source, Dest: PChar; Len: Integer);
  1374. var
  1375.   DataLoss: LongBool;
  1376. begin
  1377.   if Len > 0 then
  1378.     if Locale <> nil then
  1379.       DbiNativeToAnsi(Locale, Dest, Source, Len, DataLoss) else
  1380.       OemToCharBuff(Source, Dest, Len)
  1381. end;
  1382.  
  1383. function NativeCompareStr(Locale: TLocale; const S1, S2: string; Len: Integer): Integer;
  1384. begin
  1385.   Result := NativeCompareStrBuf(Locale, PChar(S1), PChar(S2), Len);
  1386. end;
  1387.  
  1388. function NativeCompareStrBuf(Locale: TLocale; const S1, S2: PChar; Len: Integer): Integer;
  1389. begin
  1390.   if Len > 0 then
  1391.     Result := OsLdStrnCmp(Locale, S1, S2, Len) else
  1392.     Result := OsLdStrCmp(Locale, S1, S2);
  1393. end;
  1394.  
  1395. function NativeCompareText(Locale: TLocale; const S1, S2: string; Len: Integer): Integer;
  1396. begin
  1397.   Result := NativeCompareTextBuf(Locale, PChar(S1), PChar(S2), Len);
  1398. end;
  1399.  
  1400. function NativeCompareTextBuf(Locale: TLocale; const S1, S2: PChar; Len: Integer): Integer;
  1401. begin
  1402.   if Len > 0 then
  1403.     Result := OsLdStrnCmpi(Locale, S1, S2, Len) else
  1404.     Result := OsLdStrCmpi(Locale, S1, S2);
  1405. end;
  1406.  
  1407. function IsDirectory(const DatabaseName: string): Boolean;
  1408. begin
  1409.   Result := (DatabaseName = '') or (Pos(':', DatabaseName) <> 0) or
  1410.     (Pos('\', DatabaseName) <> 0);
  1411. end;
  1412.  
  1413. function GetIntProp(const Handle: Pointer; PropName: Integer): Integer;
  1414. var
  1415.   Length: Word;
  1416.   Value: Integer;
  1417. begin
  1418.   Value := 0;
  1419.   Check(DbiGetProp(HDBIObj(Handle), propName, @Value, SizeOf(Value), Length));
  1420.   Result := Value;
  1421. end;
  1422.  
  1423. function StringListToParams(List: TStrings): string;
  1424. var
  1425.   S: String;
  1426.   P, I: Integer;
  1427. begin
  1428.   for I := 0 to List.Count - 1 do
  1429.   begin
  1430.     S := List[I];
  1431.     P := Pos('=', S);
  1432.     if (P >= 0) and (P < Length(S)) then
  1433.       Result := Format('%s%s:"%s";', [Result, Copy(S, 1, P-1), Copy(S, P+1, 255)]);
  1434.   end;
  1435.   Result := StrToOem(Result);
  1436.   SetLength(Result, Length(Result) - 1);
  1437. end;
  1438.  
  1439. { ! Add this later.
  1440. type
  1441.   EConstraintFailed = class(EDatabaseError)
  1442.     constructor Create(ErrorCode: DbiResult);
  1443.   end;
  1444.  
  1445. constructor EConstraintFailed.Create(ErrorCode: DbiResult);
  1446. var
  1447.   UserMsg: DBIMSG;
  1448. begin
  1449.   FillChar(UserMsg, SizeOf(UserMsg), #0);
  1450.   DbiGetErrorContext(ecUSERERRMSG, UserMsg);
  1451.   if UserMsg[0] <> #0 then
  1452.   begin
  1453.     Message := UserMsg;
  1454.     FillChar(UserMsg, SizeOf(UserMsg), #0);
  1455.     DbiGetErrorContext(ecFIELDNAME, UserMsg);
  1456.     if UserMsg[0] <> #0 then
  1457.       Message := Message + ' Field: '+UserMsg;
  1458.   end else
  1459.     Message := 'Constraint failed';
  1460. end;
  1461. }
  1462.  
  1463. procedure DbiError(ErrorCode: DBIResult);
  1464. begin
  1465.   if AcquiredTimer then FreeTimer;
  1466. { !
  1467.   if ErrorCode = DBIERR_CONSTRAINTFAILED then
  1468.     raise EConstraintFailed.Create(ErrorCode) else
  1469. }
  1470.   raise EDBEngineError.Create(ErrorCode);
  1471. end;
  1472.  
  1473. procedure Check(Status: DBIResult);
  1474. begin
  1475.   if Status <> 0 then DbiError(Status);
  1476. end;
  1477.  
  1478. { TDBError }
  1479.  
  1480. constructor TDBError.Create(Owner: EDBEngineError; ErrorCode: DBIResult;
  1481.   NativeError: Longint; Message: PChar);
  1482. begin
  1483.   Owner.FErrors.Add(Self);
  1484.   FErrorCode := ErrorCode;
  1485.   FNativeError := NativeError;
  1486.   FMessage := Message;
  1487. end;
  1488.  
  1489. function TDBError.GetCategory: Byte;
  1490. begin
  1491.   Result := Hi(FErrorCode);
  1492. end;
  1493.  
  1494. function TDBError.GetSubCode: Byte;
  1495. begin
  1496.   Result := Lo(FErrorCode);
  1497. end;
  1498.  
  1499. { EDBEngineError }
  1500.  
  1501. function TrimMessage(Msg: PChar): PChar;
  1502. var
  1503.   Blank: Boolean;
  1504.   Source, Dest: PChar;
  1505. begin
  1506.   Source := Msg;
  1507.   Dest := Msg;
  1508.   Blank := False;
  1509.   while Source^ <> #0 do
  1510.   begin
  1511.     if Source^ <= ' ' then Blank := True else
  1512.     begin
  1513.       if Blank then
  1514.       begin
  1515.         Dest^ := ' ';
  1516.         Inc(Dest);
  1517.         Blank := False;
  1518.       end;
  1519.       Dest^ := Source^;
  1520.       Inc(Dest);
  1521.     end;
  1522.     Inc(Source);
  1523.   end;
  1524.   if (Dest > Msg) and ((Dest - 1)^ = '.') then Dec(Dest);
  1525.   Dest^ := #0;
  1526.   Result := Msg;
  1527. end;
  1528.  
  1529. constructor EDBEngineError.Create(ErrorCode: DBIResult);
  1530. var
  1531.   ErrorIndex: Integer;
  1532.   NativeError: Longint;
  1533.   Msg: DBIMSG;
  1534.   MsgText: string;
  1535.   Messages: TStrings;
  1536. begin
  1537.   inherited Create('');
  1538.   FErrors := TList.Create;
  1539.   ErrorIndex := 1;
  1540.   if not DefaultSession.Active then
  1541.   begin
  1542.     Message := Format(SInitError, [ErrorCode]);
  1543.     TDBError.Create(Self, ErrorCode, 0, PChar(Message));
  1544.   end
  1545.   else begin
  1546.     DbiGetErrorString(ErrorCode, Msg);
  1547.     TDBError.Create(Self, ErrorCode, 0, Msg);
  1548.     TrimMessage(Msg);
  1549.     if Msg[0] = #0 then Message := Format(SBDEError, [ErrorCode]) else
  1550.     begin
  1551.       Messages := TStringList.Create;
  1552.       try
  1553.         Messages.Add(Msg);
  1554.         while True do
  1555.         begin
  1556.           ErrorCode := DbiGetErrorEntry(ErrorIndex, NativeError, Msg);
  1557.           if (ErrorCode = DBIERR_NONE) or
  1558.             (ErrorCode = DBIERR_NOTINITIALIZED) then Break;
  1559.           TDBError.Create(Self, ErrorCode, NativeError, Msg);
  1560.           TrimMessage(Msg);
  1561.           if (Msg[0] <> #0) and (Messages.IndexOf(Msg) = -1) then
  1562.             Messages.Add(Msg);
  1563.           Inc(ErrorIndex);
  1564.         end;
  1565.         MsgText := Messages.Text;
  1566.         Message := Copy(MsgText, 1, Length(MsgText)-2);
  1567.       finally
  1568.         Messages.Free;
  1569.       end;
  1570.     end;
  1571.  end;
  1572. end;
  1573.  
  1574. destructor EDBEngineError.Destroy;
  1575. var
  1576.   I: Integer;
  1577. begin
  1578.   if FErrors <> nil then
  1579.   begin
  1580.     for I := FErrors.Count - 1 downto 0 do TDBError(FErrors[I]).Free;
  1581.     FErrors.Free;
  1582.   end;
  1583.   inherited Destroy;
  1584. end;
  1585.  
  1586. function EDBEngineError.GetError(Index: Integer): TDBError;
  1587. begin
  1588.   Result := FErrors[Index];
  1589. end;
  1590.  
  1591. function EDBEngineError.GetErrorCount: Integer;
  1592. begin
  1593.   Result := FErrors.Count;
  1594. end;
  1595.  
  1596. { TSessionList }
  1597.  
  1598. constructor TSessionList.Create;
  1599. begin
  1600.   inherited Create;
  1601.   FSessions := TList.Create;
  1602.   FSessionNumbers := TBits.Create;
  1603.   InitializeCriticalSection(FCSect);
  1604. end;
  1605.  
  1606. destructor TSessionList.Destroy;
  1607. begin
  1608.   CloseAll;
  1609.   DeleteCriticalSection(FCSect);
  1610.   FSessionNumbers.Free;
  1611.   FSessions.Free;
  1612.   inherited Destroy;
  1613. end;
  1614.  
  1615. procedure TSessionList.AddSession(ASession: TSession);
  1616. begin
  1617.   if FSessions.Count = 0 then ASession.FDefault := True;
  1618.   FSessions.Add(ASession);
  1619. end;
  1620.  
  1621. procedure TSessionList.CloseAll;
  1622. var
  1623.   I: Integer;
  1624. begin
  1625.   for I := FSessions.Count-1 downto 0 do
  1626.     TSession(FSessions[I]).Free;
  1627. end;
  1628.  
  1629. function TSessionList.GetCount: Integer;
  1630. begin
  1631.   Result := FSessions.Count;
  1632. end;
  1633.  
  1634. function TSessionList.GetCurrentSession: TSession;
  1635. var
  1636.   Handle: HDBISes;
  1637.   I: Integer;
  1638. begin
  1639.   Check(DbiGetCurrSession(Handle));
  1640.   for I := 0 to FSessions.Count - 1 do
  1641.     if TSession(FSessions[I]).Handle = Handle then
  1642.     begin
  1643.       Result := TSession(FSessions[I]);
  1644.       Exit;
  1645.     end;
  1646.   Result := nil;
  1647. end;
  1648.  
  1649. function TSessionList.GetSession(Index: Integer): TSession;
  1650. begin
  1651.   Result := TSession(FSessions[Index]);
  1652. end;
  1653.  
  1654. function TSessionList.GetSessionByName(const SessionName: string): TSession;
  1655. begin
  1656.   if SessionName = '' then
  1657.     Result := Session
  1658.   else
  1659.     Result := FindSession(SessionName);
  1660.   if Result = nil then
  1661.     DatabaseErrorFmt(SInvalidSessionName, [SessionName]);
  1662. end;
  1663.  
  1664. function TSessionList.FindSession(const SessionName: string): TSession;
  1665. var
  1666.   I: Integer;
  1667. begin
  1668.   if SessionName = '' then
  1669.     Result := Session
  1670.   else
  1671.   begin
  1672.     for I := 0 to FSessions.Count - 1 do
  1673.     begin
  1674.       Result := FSessions[I];
  1675.       if AnsiCompareText(Result.SessionName, SessionName) = 0 then Exit;
  1676.     end;
  1677.     Result := nil;
  1678.   end;
  1679. end;
  1680.  
  1681. procedure TSessionList.GetSessionNames(List: TStrings);
  1682. var
  1683.   I: Integer;
  1684. begin
  1685.   List.BeginUpdate;
  1686.   try
  1687.     List.Clear;
  1688.     for I := 0 to FSessions.Count - 1 do
  1689.       with TSession(FSessions[I]) do
  1690.         List.Add(SessionName);
  1691.   finally
  1692.     List.EndUpdate;
  1693.   end;
  1694. end;
  1695.  
  1696. function TSessionList.OpenSession(const SessionName: string): TSession;
  1697. begin
  1698.   Result := FindSession(SessionName);
  1699.   if Result = nil then
  1700.   begin
  1701.     Result := TSession.Create(nil);
  1702.     Result.SessionName := SessionName;
  1703.   end;
  1704.   Result.SetActive(True);
  1705. end;
  1706.  
  1707. procedure TSessionList.SetCurrentSession(Value: TSession);
  1708. begin
  1709.   Check(DbiSetCurrSession(Value.FHandle))
  1710. end;
  1711.  
  1712. { TSession }
  1713.  
  1714. constructor TSession.Create(AOwner: TComponent);
  1715. begin
  1716.   ValidateAutoSession(AOwner, False);
  1717.   inherited Create(AOwner);
  1718.   Exclude(FComponentStyle, csInheritable);
  1719.   FDatabases := TList.Create;
  1720.   FCallbacks := TList.Create;
  1721.   FKeepConnections := True;
  1722.   FSQLHourGlass := True;
  1723.   Sessions.AddSession(Self);
  1724.   FHandle := nil;
  1725. end;
  1726.  
  1727. destructor TSession.Destroy;
  1728. begin
  1729.   SetActive(False);
  1730.   Sessions.FSessions.Remove(Self);
  1731.   FDatabases.Free;
  1732.   FCallbacks.Free;
  1733.   inherited Destroy;
  1734. end;
  1735.  
  1736. procedure TSession.AddAlias(const Name, Driver: string; List: TStrings);
  1737. begin
  1738.   InternalAddAlias(Name, Driver, List, ConfigMode, True);
  1739. end;
  1740.  
  1741. procedure TSession.AddDriver(const Name: string; List: TStrings);
  1742. var
  1743.   Params: string;
  1744.   CfgModeSave: TConfigMode;
  1745. begin
  1746.   Params := StringListToParams(List);
  1747.   LockSession;
  1748.   try
  1749.     CfgModeSave := ConfigMode;
  1750.     try
  1751.       CheckConfigMode(ConfigMode);
  1752.       Check(DbiAddDriver(nil, PChar(StrToOem(Name)), PChar(Params), Bool(-1)));
  1753.     finally
  1754.       ConfigMode := cfgModeSave;
  1755.     end;
  1756.   finally
  1757.     UnlockSession;
  1758.   end;
  1759.   DBNotification(dbAddDriver, Pointer(Name));
  1760. end;
  1761.  
  1762. procedure TSession.AddDatabase(Value: TDatabase);
  1763. begin
  1764.   FDatabases.Add(Value);
  1765.   DBNotification(dbAdd, Value);
  1766. end;
  1767.  
  1768. procedure TSession.AddStandardAlias(const Name, Path, DefaultDriver: string);
  1769. var
  1770.   AliasParams: TStringList;
  1771. begin
  1772.   AliasParams := TStringList.Create;
  1773.   try
  1774.     AliasParams.Add(Format('%s=%s', [szCFGDBPATH, Path]));
  1775.     AliasParams.Add(Format('%s=%s', [szCFGDBDEFAULTDRIVER, DefaultDriver]));
  1776.     AddAlias(Name, szCFGDBSTANDARD, AliasParams);
  1777.   finally
  1778.     AliasParams.Free;
  1779.   end;
  1780. end;
  1781.  
  1782. procedure TSession.AddPassword(const Password: string);
  1783. var
  1784.   Buffer: array[0..255] of Char;
  1785. begin
  1786.   LockSession;
  1787.   try
  1788.     if Password <> '' then
  1789.       Check(DbiAddPassword(AnsiToNative(Locale, Password, Buffer,
  1790.         SizeOf(Buffer) - 1)));
  1791.   finally
  1792.     UnlockSession;
  1793.   end;
  1794. end;
  1795.  
  1796. procedure TSession.CallBDEInitProcs;
  1797. var
  1798.   I: Integer;
  1799. begin
  1800.   if Assigned(BDEInitProcs) then
  1801.     for I := 0 to BDEInitProcs.Count - 1 do
  1802.       TBDEInitProc(BDEInitProcs[I])(Self);
  1803. end;
  1804.  
  1805. procedure TSession.CheckInactive;
  1806. begin
  1807.   if Active then
  1808.     DatabaseError(SSessionActive);
  1809. end;
  1810.  
  1811. procedure TSession.CheckConfigMode(CfgMode: TConfigMode);
  1812. begin
  1813.   if CfgMode = cmAll then CfgMode := cmPersistent;
  1814.   ConfigMode := CfgMode;
  1815. end;
  1816.  
  1817. procedure TSession.Close;
  1818. begin
  1819.   SetActive(False);
  1820. end;
  1821.  
  1822. procedure TSession.CloseDatabase(Database: TDatabase);
  1823. begin
  1824.   with Database do
  1825.   begin
  1826.     if FRefCount <> 0 then Dec(FRefCount);
  1827.     if (FRefCount = 0) and not KeepConnection then
  1828.       if not Temporary then Close else
  1829.          if not (csDestroying in ComponentState) then Free;
  1830.   end;
  1831. end;
  1832.  
  1833. function TSession.DBLoginCallback(CBInfo: Pointer): CBRType;
  1834. var
  1835.   Database: TDatabase;
  1836.   UserName, Password: string;
  1837.   AliasParams: TStringList;
  1838. begin
  1839.   Result := cbrYES;
  1840.   with PCBDBLogin(CBInfo)^ do
  1841.   try
  1842.     if hDB = nil then
  1843.     begin
  1844.       if not FBDEOwnsLoginCbDb then
  1845.       begin
  1846.         hDb := OpenDatabase(szDbName).Handle;
  1847.         if not Assigned(hDb) then
  1848.           Result := cbrAbort
  1849.         else
  1850.           bCallbackToClose := True;
  1851.       end else
  1852.       begin
  1853.         AliasParams := TStringList.Create;
  1854.         try
  1855.           GetAliasParams(szDbName, AliasParams);
  1856.           UserName := AliasParams.Values[szUSERNAME];
  1857.         finally
  1858.           AliasParams.Free;
  1859.         end;
  1860.         Password := '';
  1861.         if LoginDialogEx(szDbName, UserName, Password, True) then
  1862.         begin
  1863.           AnsiToNative(Locale, Password, szPassword, SizeOf(szPassword) - 1);
  1864.           bCallbackToClose := False;
  1865.         end
  1866.         else
  1867.           Result :=cbrAbort;
  1868.       end
  1869.     end else
  1870.     begin
  1871.       Database := FindDatabase(szDbName);
  1872.       if Assigned(Database) and (hDB = Database.Handle) then
  1873.         CloseDatabase(Database);
  1874.     end;
  1875.   except
  1876.     Result := cbrAbort;
  1877.   end;
  1878. end;
  1879.  
  1880. procedure TSession.DBNotification(DBEvent: TDatabaseEvent; const Param);
  1881. begin
  1882.   if Assigned(FOnDBNotify) then FOnDBNotify(DBEvent, Param);
  1883. end;
  1884.  
  1885. procedure TSession.DeleteAlias(const Name: string);
  1886. begin
  1887.   InternalDeleteAlias(Name, ConfigMode, True);
  1888. end;
  1889.  
  1890. procedure TSession.DeleteDriver(const Name: string);
  1891. begin
  1892.   DBNotification(dbDeleteDriver, Pointer(Name));
  1893.   LockSession;
  1894.   try
  1895.     DbiDeleteDriver(nil, PChar(StrToOem(Name)), False);
  1896.   finally
  1897.     UnlockSession;
  1898.   end;
  1899. end;
  1900.  
  1901. procedure TSession.DeleteConfigPath(const Path, Node: string);
  1902. var
  1903.   CfgPath: string;
  1904. begin
  1905.   CfgPath := Format(Path, [Node]);
  1906.   if DbiCfgPosition(nil, PChar(CfgPath)) = 0 then
  1907.     Check(DbiCfgDropRecord(nil, PChar(CfgPath)));
  1908. end;
  1909.  
  1910. procedure TSession.DropConnections;
  1911. var
  1912.   I: Integer;
  1913. begin
  1914.   for I := FDatabases.Count - 1 downto 0 do
  1915.     with TDatabase(FDatabases[I]) do
  1916.       if Temporary and (FRefCount = 0) then Free;
  1917. end;
  1918.  
  1919. function TSession.FindDatabase(const DatabaseName: string): TDatabase;
  1920. var
  1921.   I: Integer;
  1922. begin
  1923.   for I := 0 to FDatabases.Count - 1 do
  1924.   begin
  1925.     Result := FDatabases[I];
  1926.     if ((Result.DatabaseName <> '') or Result.Temporary) and
  1927.       (AnsiCompareText(Result.DatabaseName, DatabaseName) = 0) then Exit;
  1928.   end;
  1929.   Result := nil;
  1930. end;
  1931.  
  1932. function TSession.GetActive: Boolean;
  1933. begin
  1934.   Result := FHandle <> nil;
  1935. end;
  1936.  
  1937. function TSession.GetAliasDriverName(const AliasName: string): string;
  1938. var
  1939.   Desc: DBDesc;
  1940. begin
  1941.   LockSession;
  1942.   try
  1943.     if DbiGetDatabaseDesc(PChar(StrToOem(AliasName)), @Desc) <> 0 then
  1944.       DatabaseErrorFmt(SInvalidAliasName, [AliasName]);
  1945.   finally
  1946.     UnlockSession;
  1947.   end;
  1948.   if Desc.szDBType[sizeOf(Desc.szDBType) - 1] <> #0 then
  1949.     Desc.szDBType[sizeOf(Desc.szDBType) - 1] := #0;
  1950.   OemToChar(Desc.szDBType, Desc.szDBType);
  1951.   Result := Desc.szDBType;
  1952. end;
  1953.  
  1954. procedure TSession.GetAliasNames(List: TStrings);
  1955. var
  1956.   Cursor: HDBICur;
  1957.   Desc: DBDesc;
  1958. begin
  1959.   List.BeginUpdate;
  1960.   try
  1961.     List.Clear;
  1962.     LockSession;
  1963.     try
  1964.       Check(DbiOpenDatabaseList(Cursor));
  1965.     finally
  1966.       UnlockSession;
  1967.     end;
  1968.     try
  1969.       while DbiGetNextRecord(Cursor, dbiNOLOCK, @Desc, nil) = 0 do
  1970.       begin
  1971.         OemToChar(Desc.szName, Desc.szName);
  1972.         List.Add(Desc.szName);
  1973.       end;
  1974.     finally
  1975.       DbiCloseCursor(Cursor);
  1976.     end;
  1977.   finally
  1978.     List.EndUpdate;
  1979.   end;
  1980. end;
  1981.  
  1982. procedure TSession.GetAliasParams(const AliasName: string; List: TStrings);
  1983. var
  1984.   SAlias: DBIName;
  1985.   Desc: DBDesc;
  1986. begin
  1987.   List.BeginUpdate;
  1988.   try
  1989.     List.Clear;
  1990.     StrPLCopy(SAlias, AliasName, SizeOf(SAlias) - 1);
  1991.     CharToOEM(SAlias, SAlias);
  1992.     LockSession;
  1993.     try
  1994.       Check(DbiGetDatabaseDesc(SAlias, @Desc));
  1995.     finally
  1996.       UnlockSession;
  1997.     end;
  1998.     if Desc.szDBType[sizeOf(Desc.szDBType) - 1] <> #0 then
  1999.       Desc.szDBType[sizeOf(Desc.szDBType) - 1] := #0;
  2000.     if StrIComp(Desc.szDbType, szCFGDBSTANDARD) = 0 then
  2001.     begin
  2002.       GetConfigParams('\DATABASES\%s\DB INFO', SAlias, List);
  2003.       List.Values[szCFGDBTYPE] := '';
  2004.     end
  2005.     else
  2006.       GetConfigParams('\DATABASES\%s\DB OPEN', SAlias, List);
  2007.   finally
  2008.     List.EndUpdate;
  2009.   end;
  2010. end;
  2011.  
  2012. procedure TSession.GetConfigParams(const Path, Section: string; List: TStrings);
  2013. var
  2014.   Cursor: HDBICur;
  2015.   ConfigDesc: CFGDesc;
  2016. begin
  2017.   LockSession;
  2018.   try
  2019.     Check(DbiOpenCfgInfoList(nil, dbiREADONLY, cfgPERSISTENT, PChar(Format(Path,
  2020.       [Section])), Cursor));
  2021.   finally
  2022.     UnlockSession;
  2023.   end;
  2024.   try
  2025.     while DbiGetNextRecord(Cursor, dbiNOLOCK, @ConfigDesc, nil) = 0 do
  2026.       with ConfigDesc do
  2027.       begin
  2028.         OemToChar(szValue, szValue);
  2029.         List.Add(Format('%s=%s', [szNodeName, szValue]));
  2030.       end;
  2031.   finally
  2032.     DbiCloseCursor(Cursor);
  2033.   end;
  2034. end;
  2035.  
  2036. function TSession.GetDatabase(Index: Integer): TDatabase;
  2037. begin
  2038.   Result := FDatabases[Index];
  2039. end;
  2040.  
  2041. function TSession.GetDatabaseCount: Integer;
  2042. begin
  2043.   Result := FDatabases.Count;
  2044. end;
  2045.  
  2046. procedure TSession.GetDatabaseNames(List: TStrings);
  2047. var
  2048.   I: Integer;
  2049.   Names: TStringList;
  2050. begin
  2051.   Names := TStringList.Create;
  2052.   try
  2053.     Names.Sorted := True;
  2054.     GetAliasNames(Names);
  2055.     for I := 0 to FDatabases.Count - 1 do
  2056.       with TDatabase(FDatabases[I]) do
  2057.         if not IsDirectory(DatabaseName) then Names.Add(DatabaseName);
  2058.     List.Assign(Names);
  2059.   finally
  2060.     Names.Free;
  2061.   end;
  2062. end;
  2063.  
  2064. procedure TSession.GetDriverNames(List: TStrings);
  2065. var
  2066.   Cursor: HDBICur;
  2067.   Name: array[0..255] of Char;
  2068. begin
  2069.   List.BeginUpdate;
  2070.   try
  2071.     List.Clear;
  2072.     List.Add(szCFGDBSTANDARD);
  2073.     LockSession;
  2074.     try
  2075.       Check(DbiOpenDriverList(Cursor));
  2076.     finally
  2077.       UnlockSession;
  2078.     end;
  2079.     try
  2080.       while DbiGetNextRecord(Cursor, dbiNOLOCK, @Name, nil) = 0 do
  2081.         if (StrIComp(Name, szPARADOX) <> 0) and
  2082.           (StrIComp(Name, szDBASE) <> 0) then
  2083.         begin
  2084.           OemToChar(Name, Name);
  2085.           List.Add(Name);
  2086.         end;
  2087.     finally
  2088.       DbiCloseCursor(Cursor);
  2089.     end;
  2090.   finally
  2091.     List.EndUpdate;
  2092.   end;
  2093. end;
  2094.  
  2095. procedure TSession.GetDriverParams(const DriverName: string;
  2096.   List: TStrings);
  2097. begin
  2098.   List.BeginUpdate;
  2099.   try
  2100.     List.Clear;
  2101.     if CompareText(DriverName, szCFGDBSTANDARD) = 0 then
  2102.     begin
  2103.       List.Add(Format('%s=', [szCFGDBPATH]));
  2104.       List.Add(Format('%s=%s', [szCFGDBDEFAULTDRIVER, szPARADOX]));
  2105.       List.Add(Format('%s=%s', [szCFGDBENABLEBCD, szCFGFALSE]));
  2106.     end
  2107.     else
  2108.       GetConfigParams('\DRIVERS\%s\DB OPEN', StrToOem(DriverName), List);
  2109.   finally
  2110.     List.EndUpdate;
  2111.   end;
  2112. end;
  2113.  
  2114. function TSession.GetHandle: HDBISes;
  2115. begin
  2116.   if FHandle <> nil then
  2117.     Check(DbiSetCurrSession(FHandle))
  2118.   else
  2119.     SetActive(True);
  2120.   Result := FHandle;
  2121. end;
  2122.  
  2123. function TSession.GetNetFileDir: string;
  2124. var
  2125.   Length: Word;
  2126.   Buffer: array[0..255] of Char;
  2127. begin
  2128.   if Active and not (csWriting in ComponentState) then
  2129.   begin
  2130.     LockSession;
  2131.     try
  2132.       Check(DbiGetProp(HDBIOBJ(FHandle), sesNETFILE, @Buffer, SizeOf(Buffer),
  2133.         Length));
  2134.     finally
  2135.       UnLockSession;
  2136.     end;
  2137.     NativeToAnsi(nil, Buffer, Result);
  2138.   end else
  2139.     Result := FNetFileDir;
  2140.   Result := AnsiUpperCase(Result);
  2141. end;
  2142.  
  2143. function TSession.GetPrivateDir: string;
  2144. var
  2145.   SessionInfo: SESInfo;
  2146. begin
  2147.   if Active and not (csWriting in ComponentState) then
  2148.   begin
  2149.     LockSession;
  2150.     try
  2151.       Check(DbiGetSesInfo(SessionInfo));
  2152.     finally
  2153.       UnlockSession;
  2154.     end;
  2155.     NativeToAnsi(nil, SessionInfo.szPrivDir, Result);
  2156.   end else
  2157.     Result := FPrivateDir;
  2158.   Result := AnsiUpperCase(Result);
  2159. end;
  2160.  
  2161. function TSession.GetPassword: Boolean;
  2162. begin
  2163.   if Assigned(FOnPassword) then
  2164.   begin
  2165.     Result := False;
  2166.     FOnPassword(Self, Result)
  2167.   end else
  2168.     Result := PasswordDialog(Self);
  2169. end;
  2170.  
  2171. procedure TSession.GetTableNames(const DatabaseName, Pattern: string;
  2172.   Extensions, SystemTables: Boolean; List: TStrings);
  2173. var
  2174.   Database: TDatabase;
  2175.   Cursor: HDBICur;
  2176.   WildCard: PChar;
  2177.   Name: string;
  2178.   SPattern: array[0..127] of Char;
  2179.   Desc: TBLBaseDesc;
  2180. begin
  2181.   List.BeginUpdate;
  2182.   try
  2183.     List.Clear;
  2184.     Database := OpenDatabase(DatabaseName);
  2185.     try
  2186.       WildCard := nil;
  2187.       if Pattern <> '' then
  2188.         WildCard := AnsiToNative(Database.Locale, Pattern, SPattern,
  2189.           SizeOf(SPattern) - 1);
  2190.       Check(DbiOpenTableList(Database.Handle, False, SystemTables,
  2191.         WildCard, Cursor));
  2192.       try
  2193.         while DbiGetNextRecord(Cursor, dbiNOLOCK, @Desc, nil) = 0 do
  2194.           with Desc do
  2195.           begin
  2196.             if Extensions and (szExt[0] <> #0) then
  2197.               StrCat(StrCat(szName, '.'), szExt);
  2198.             NativeToAnsi(Database.Locale, szName, Name);
  2199.             List.Add(Name);
  2200.           end;
  2201.       finally
  2202.         DbiCloseCursor(Cursor);
  2203.       end;
  2204.     finally
  2205.       CloseDatabase(Database);
  2206.     end;
  2207.   finally
  2208.     List.EndUpdate;
  2209.   end;
  2210. end;
  2211.  
  2212. procedure TSession.GetStoredProcNames(const DatabaseName: string; List: TStrings);
  2213. var
  2214.   Database: TDatabase;
  2215.   Cursor: HDBICur;
  2216.   Name: string;
  2217.   Desc: SPDesc;
  2218. begin
  2219.   List.BeginUpdate;
  2220.   try
  2221.     List.Clear;
  2222.     Database := OpenDatabase(DatabaseName);
  2223.     try
  2224.       Check(DbiOpenSPList(Database.Handle, False, True, nil, Cursor));
  2225.       try
  2226.         while DbiGetNextRecord(Cursor, dbiNOLOCK, @Desc, nil) = 0 do
  2227.           with Desc do
  2228.           begin
  2229.             NativeToAnsi(Database.Locale, szName, Name);
  2230.             List.Add(Name);
  2231.           end;
  2232.       finally
  2233.         DbiCloseCursor(Cursor);
  2234.       end;
  2235.     finally
  2236.       CloseDatabase(Database);
  2237.     end;
  2238.   finally
  2239.     List.EndUpdate;
  2240.   end;
  2241. end;
  2242.  
  2243. procedure TSession.InitializeBDE;
  2244. const
  2245.   StartFlags: LongInt = 0;
  2246. var
  2247.   Status: DBIResult;
  2248.   Env: DbiEnv;
  2249.   ClientHandle: hDBIObj;
  2250.   SetCursor: Boolean;
  2251. begin
  2252.   SetCursor := GetCurrentThreadID = MainThreadID;
  2253.   if SetCursor then
  2254.     Screen.Cursor := crHourGlass;
  2255.   try
  2256.     FillChar(Env, SizeOf(Env), 0);
  2257.     StrPLCopy(Env.szLang, SIDAPILangID, SizeOf(Env.szLang) - 1);
  2258.     Status := DbiInit(@Env);
  2259.     if (Status <> DBIERR_NONE) and (Status <> DBIERR_MULTIPLEINIT) then
  2260.       DatabaseErrorFmt(SInitError, [Status]);
  2261.     Check(DbiGetCurrSession(FHandle));
  2262.     if DbiGetObjFromName(objCLIENT, nil, ClientHandle) = 0 then
  2263.       DbiSetProp(ClientHandle, clSQLRESTRICT, StartFlags);
  2264.     if IsLibrary then
  2265.       DbiRegisterCallback(nil, cbDETACHNOTIFY, 0, 0, nil, DLLDetachCallBack);
  2266.   finally
  2267.     if SetCursor then
  2268.       Screen.Cursor := crDefault;
  2269.   end;
  2270. end;
  2271.  
  2272. procedure TSession.InternalAddAlias(const Name, Driver: string; List: TStrings;
  2273.   CfgMode: TConfigMode; RestoreMode: Boolean);
  2274. var
  2275.   Params: string;
  2276.   DrvName: string;
  2277.   CfgModeSave: TConfigMode;
  2278. begin
  2279.   Params := StringListToParams(List);
  2280.   DrvName := List.Values[szCFGDBDEFAULTDRIVER];
  2281.   if (DrvName = '') and (CompareText(Driver, szCFGDBSTANDARD) <> 0) then
  2282.     DrvName := Driver;
  2283.   LockSession;
  2284.   try
  2285.     CfgModeSave := ConfigMode;
  2286.     try
  2287.       CheckConfigMode(CfgMode);
  2288.       Check(DbiAddAlias(nil, PChar(StrToOem(Name)), PChar(StrToOem(DrvName)), PChar(Params), Bool(-1)));
  2289.     finally
  2290.       if RestoreMode then ConfigMode := CfgModeSave;
  2291.     end;
  2292.   finally
  2293.     UnlockSession;
  2294.   end;
  2295.   DBNotification(dbAddAlias, Pointer(Name));
  2296. end;
  2297.  
  2298. procedure TSession.InternalDeleteAlias(const Name: string;
  2299.   CfgMode: TConfigMode; RestoreMode: Boolean);
  2300. var
  2301.   CfgModeSave: TConfigMode;
  2302. begin
  2303.   DBNotification(dbDeleteAlias, Pointer(Name));
  2304.   LockSession;
  2305.   try
  2306.     CfgModeSave := ConfigMode;
  2307.     try
  2308.       CheckConfigMode(CfgMode);
  2309.       DeleteConfigPath('\DATABASES\%s', StrToOem(Name));
  2310.     finally
  2311.       if RestoreMode then ConfigMode := cfgModeSave;
  2312.     end;
  2313.   finally
  2314.     UnlockSession;
  2315.   end;
  2316. end;
  2317.  
  2318. function TSession.IsAlias(const Name: string): Boolean;
  2319. begin
  2320.   MakeCurrent;
  2321.   Result := DbiCfgPosition(nil, PChar(Format('\DATABASES\%s', [Name]))) = 0;
  2322. end;
  2323.  
  2324. procedure TSession.Loaded;
  2325. begin
  2326.   inherited Loaded;
  2327.   try
  2328.     if FStreamedAutoSessionName then SetAutoSessionName(True);
  2329.     if FStreamedActive then SetActive(True);
  2330.   except
  2331.     if csDesigning in ComponentState then
  2332.       Application.HandleException(Self)
  2333.     else
  2334.       raise;
  2335.   end;
  2336. end;
  2337.  
  2338. procedure TSession.LockSession;
  2339. begin
  2340.   if FLockCount = 0 then
  2341.   begin
  2342.     EnterCriticalSection(FCSect);
  2343.     Inc(FLockCount);
  2344.     MakeCurrent;
  2345.   end
  2346.   else
  2347.     Inc(FLockCount);
  2348. end;
  2349.  
  2350. procedure TSession.UnLockSession;
  2351. begin
  2352.   Dec(FLockCount);
  2353.   if FLockCount = 0 then
  2354.     LeaveCriticalSection(FCSect);
  2355. end;
  2356.  
  2357. procedure TSession.MakeCurrent;
  2358. begin
  2359.   if FHandle <> nil then
  2360.     Check(DbiSetCurrSession(FHandle))
  2361.   else
  2362.     SetActive(True);
  2363. end;
  2364.  
  2365. procedure TSession.ModifyAlias(Name: string; List: TStrings);
  2366. var
  2367.   DriverName: string;
  2368.   OemName: string;
  2369.   CfgModeSave: TConfigMode;
  2370. begin
  2371.   LockSession;
  2372.   try
  2373.     CfgModeSave := ConfigMode;
  2374.     try
  2375.       CheckConfigMode(ConfigMode);
  2376.       DriverName := GetAliasDriverName(Name);
  2377.       OemName := StrToOem(Name);
  2378.       ModifyConfigParams('\DATABASES\%s\DB INFO', OemName, List);
  2379.       if CompareText(DriverName, szCFGDBSTANDARD) <> 0 then
  2380.         ModifyConfigParams('\DATABASES\%s\DB OPEN', OemName, List);
  2381.     finally
  2382.       ConfigMode := CfgModeSave;
  2383.     end;
  2384.   finally
  2385.     UnLockSession;
  2386.   end;
  2387. end;
  2388.  
  2389. procedure TSession.ModifyDriver(Name: string; List: TStrings);
  2390. var
  2391.   CfgModeSave: TConfigMode;
  2392.   OemName: string;
  2393. begin
  2394.   LockSession;
  2395.   try
  2396.     CfgModeSave := ConfigMode;
  2397.     try
  2398.       CheckConfigMode(ConfigMode);
  2399.       OemName := StrToOem(Name);
  2400.       ModifyConfigParams('\DRIVERS\%s\INIT', OemName, List);
  2401.       if (StrIComp(PChar(Name), szPARADOX) = 0) or
  2402.          (StrIComp(PChar(Name), szDBASE) = 0) then
  2403.         ModifyConfigParams('\DRIVERS\%s\TABLE CREATE', OemName, List) else
  2404.         ModifyConfigParams('\DRIVERS\%s\DB OPEN', OemName, List);
  2405.     finally
  2406.       ConfigMode := CfgModeSave;
  2407.     end;
  2408.   finally
  2409.     UnLockSession;
  2410.   end;
  2411. end;
  2412.  
  2413. procedure TSession.ModifyConfigParams(const Path, Node: string; List: TStrings);
  2414. var
  2415.   I, J, C: Integer;
  2416.   Params: TStrings;
  2417. begin
  2418.   Params := TStringList.Create;
  2419.   try
  2420.     GetConfigParams(Path, Node, Params);
  2421.     C := 0;
  2422.     for I := 0 to Params.Count - 1 do
  2423.     begin
  2424.       J := List.IndexOfName(Params.Names[I]);
  2425.       if J >= 0 then
  2426.       begin
  2427.         Params[I] := List[J];
  2428.         Inc(C);
  2429.       end;
  2430.     end;
  2431.     if C > 0 then SetConfigParams(Path, Node, Params);
  2432.   finally
  2433.     Params.Free;
  2434.   end;
  2435. end;
  2436.  
  2437. procedure TSession.Notification(AComponent: TComponent; Operation: TOperation);
  2438. begin
  2439.   inherited Notification(AComponent, Operation);
  2440.   if AutoSessionName and (Operation = opInsert) and (AComponent is TDBDataSet) then
  2441.     TDBDataSet(AComponent).SessionName := Self.SessionName;
  2442. end;
  2443.  
  2444. procedure TSession.Open;
  2445. begin
  2446.   SetActive(True);
  2447. end;
  2448.  
  2449. function TSession.OpenDatabase(const DatabaseName: string): TDatabase;
  2450. var
  2451.   TempDatabase: TDatabase;
  2452. begin
  2453.   MakeCurrent;
  2454.   TempDatabase := nil;
  2455.   try
  2456.     Result := FindDatabase(DatabaseName);
  2457.     if Result = nil then
  2458.     begin
  2459.       TempDatabase := TDatabase.Create(Self);
  2460.       TempDatabase.DatabaseName := DatabaseName;
  2461.       TempDatabase.KeepConnection := FKeepConnections;
  2462.       TempDatabase.Temporary := True;
  2463.       Result := TempDatabase;
  2464.     end;
  2465.     Result.Open;
  2466.     Inc(Result.FRefCount);
  2467.   except
  2468.     TempDatabase.Free;
  2469.     raise;
  2470.   end;
  2471. end;
  2472.  
  2473. function TSession.SessionNameStored: Boolean;
  2474. begin
  2475.   Result := not FAutoSessionName;
  2476. end;
  2477.  
  2478. procedure TSession.LoadSMClient;
  2479. var
  2480.   FM: THandle;
  2481.   ClientName: string;
  2482.   FOldCBFunc: pfDBICallBack;
  2483. begin
  2484.   try
  2485.     if Assigned(FSMClient) or (DbiGetCallBack(nil, cbTrace, nil, nil, nil,
  2486.       FOldCBFunc) = DBIERR_NONE) or FSMLoadFailed then Exit;
  2487.     FM := OpenFileMapping(FILE_MAP_READ, False, 'SMBuffer'); { Do not localize }
  2488.     if FM = 0 then Exit;
  2489.     CloseHandle(FM);
  2490.     if FDefault then
  2491.       CoCreateInstance(Class_SMClient, nil, CLSCTX_INPROC_SERVER, ISMClient,
  2492.       FSMClient) else FSMClient := DefaultSession.FSMClient;
  2493.     if Assigned(FSMClient) then
  2494.     begin
  2495.       ClientName := Application.Title;
  2496.       if ClientName = '' then  ClientName := SUntitled;
  2497.       if not FDefault then
  2498.         ClientName := Format('%s.%s', [ClientName, SessionName]);
  2499.       if FSMClient.RegisterClient(Integer(FHandle), PChar(ClientName), Self,
  2500.          @TSession.SMClientSignal) then
  2501.       begin
  2502.         GetMem(FSMBuffer, smTraceBufSize);
  2503.         FCallbacks.Add(TBDECallback.Create(Self, nil, cbTRACE,
  2504.           FSMBuffer, smTraceBufSize, SqlTraceCallBack, False));
  2505.       end else
  2506.         FSMClient := nil;
  2507.       FSMLoadFailed := FSMClient = nil;;
  2508.     end;
  2509.   except
  2510.     FSMLoadFailed := True;
  2511.   end;
  2512. end;
  2513.  
  2514. procedure TSession.RegisterCallbacks(Value: Boolean);
  2515. var
  2516.   I: Integer;
  2517. begin
  2518.   if Value then
  2519.   begin
  2520.     if FSQLHourGlass then
  2521.       FCallbacks.Add(TBDECallback.Create(Self, nil, cbSERVERCALL,
  2522.         @FCBSCType, SizeOf(CBSCType), ServerCallBack, False));
  2523.  
  2524.     FCallbacks.Add(TBDECallback.Create(Self, nil, cbDBLOGIN,
  2525.       @FCBDBLogin, SizeOf(TCBDBLogin), DBLoginCallBack, False));
  2526.   end else
  2527.   begin
  2528.     for I := FCallbacks.Count - 1 downto 0 do
  2529.       TBDECallback(FCallbacks[I]).Free;
  2530.     FCallbacks.Clear;
  2531.     if Assigned(FSMClient) then
  2532.     try
  2533.       FreeMem(FSMBuffer, smTraceBufSize);
  2534.       FSMClient := nil;
  2535.     except
  2536.     end;
  2537.   end;
  2538. end;
  2539.  
  2540. procedure TSession.RemoveDatabase(Value: TDatabase);
  2541. begin
  2542.   FDatabases.Remove(Value);
  2543.   DBNotification(dbRemove, Value);
  2544. end;
  2545.  
  2546. procedure TSession.RemoveAllPasswords;
  2547. begin
  2548.   LockSession;
  2549.   try
  2550.     DbiDropPassword(nil);
  2551.   finally
  2552.     UnlockSession;
  2553.   end;
  2554. end;
  2555.  
  2556. procedure TSession.RemovePassword(const Password: string);
  2557. var
  2558.   Buffer: array[0..255] of Char;
  2559. begin
  2560.   LockSession;
  2561.   try
  2562.     if Password <> '' then
  2563.       DbiDropPassword(AnsiToNative(Locale, Password, Buffer,
  2564.         SizeOf(Buffer) - 1));
  2565.   finally
  2566.     UnlockSession;
  2567.   end;
  2568. end;
  2569.  
  2570. procedure TSession.SaveConfigFile;
  2571. var
  2572.   CfgModeSave: TConfigMode;
  2573. begin
  2574.   CfgModeSave := ConfigMode;
  2575.   try
  2576.     ConfigMode := cmPersistent;
  2577.     Check(DbiCfgSave(nil, nil, Bool(-1)));
  2578.   finally
  2579.     ConfigMode := CfgModeSave;
  2580.   end;
  2581. end;
  2582.  
  2583. function TSession.ServerCallBack(CBInfo: Pointer): CBRType;
  2584. const
  2585.   MinWait = 500;
  2586. begin
  2587.   Result := cbrUSEDEF;
  2588.   if (FCBSCType = cbscSQL) and (GetCurrentThreadID = MainThreadID) then
  2589.   begin
  2590.     if StartTime = 0 then
  2591.     begin
  2592.       TimerID := SetTimer(0, 0, 1000, @TimerCallBack);
  2593.       AcquiredTimer := TimerID <> 0;
  2594.       StartTime := GetTickCount;
  2595.     end
  2596.     else if AcquiredTimer and (GetTickCount - StartTime > MinWait) then
  2597.       Screen.Cursor := crSQLWait;
  2598.   end;
  2599. end;
  2600.  
  2601. procedure TSession.SetActive(Value: Boolean);
  2602. begin
  2603.   if csReading in ComponentState then
  2604.     FStreamedActive := Value
  2605.   else
  2606.     if Active <> Value then
  2607.       StartSession(Value);
  2608. end;
  2609.  
  2610. procedure TSession.SetAutoSessionName(Value: Boolean);
  2611. begin
  2612.   if csReading in ComponentState then
  2613.     FStreamedAutoSessionName := Value
  2614.   else
  2615.     if Value <> FAutoSessionName then
  2616.     begin
  2617.       if Value then
  2618.       begin
  2619.         CheckInActive;
  2620.         ValidateAutoSession(Owner, True);
  2621.         FSessionNumber := -1;
  2622.         EnterCriticalSection(FCSect);
  2623.         try
  2624.           with Sessions do
  2625.           begin
  2626.             FSessionNumber := FSessionNumbers.OpenBit;
  2627.             FSessionNumbers[FSessionNumber] := True;
  2628.           end;
  2629.         finally
  2630.           LeaveCriticalSection(FCSect);
  2631.         end;
  2632.         UpdateAutoSessionName;
  2633.       end
  2634.       else
  2635.       begin
  2636.         if FSessionNumber > -1 then
  2637.         begin
  2638.           EnterCriticalSection(FCSect);
  2639.           try
  2640.             Sessions.FSessionNumbers[FSessionNumber] := False;
  2641.           finally
  2642.             LeaveCriticalSection(FCSect);
  2643.           end;
  2644.         end;
  2645.       end;
  2646.       FAutoSessionName := Value;
  2647.     end;
  2648. end;
  2649.  
  2650. function TSession.GetConfigMode: TConfigMode;
  2651. begin
  2652.   LockSession;
  2653.   try
  2654.     Result := TConfigMode(Byte(GetIntProp(FHandle, sesCFGMODE2)));
  2655.   finally
  2656.     UnlockSession;
  2657.   end;
  2658. end;
  2659.  
  2660. procedure TSession.SetConfigMode(Value: TConfigMode);
  2661. begin
  2662.   LockSession;
  2663.   try
  2664.     Check(DbiSetProp(hDBIObj(FHandle), sesCFGMODE2, Longint(Byte(Value))));
  2665.   finally
  2666.     UnlockSession;
  2667.   end;
  2668. end;
  2669.  
  2670. procedure TSession.SetConfigParams(const Path, Node: string; List: TStrings);
  2671. var
  2672.   ParamList: TParamList;
  2673. begin
  2674.   ParamList := TParamList.Create(List);
  2675.   try
  2676.     with ParamList do
  2677.       Check(DbiCfgModifyRecord(nil, PChar(Format(Path, [Node])), FieldCount,
  2678.         PFLDDesc(FieldDescs), Buffer));
  2679.   finally
  2680.     ParamList.Free;
  2681.   end;
  2682. end;
  2683.  
  2684. procedure TSession.SetName(const NewName: TComponentName);
  2685. begin
  2686.   inherited SetName(NewName);
  2687.   if FAutoSessionName then UpdateAutoSessionName;
  2688. end;
  2689.  
  2690. procedure TSession.SetNetFileDir(const Value: string);
  2691. var
  2692.   Buffer: array[0..255] of Char;
  2693. begin
  2694.   if Active then
  2695.   begin
  2696.     LockSession;
  2697.     try
  2698.       Check(DbiSetProp(HDBIOBJ(Handle), sesNETFILE, Longint(AnsiToNative(nil,
  2699.         Value, Buffer, SizeOf(Buffer) - 1))));
  2700.     finally
  2701.       UnLockSession;
  2702.     end;
  2703.   end;
  2704.   FNetFileDir := Value;
  2705. end;
  2706.  
  2707. procedure TSession.SetPrivateDir(const Value: string);
  2708. var
  2709.   Buffer: array[0..255] of Char;
  2710. begin
  2711.   if Active then
  2712.   begin
  2713.     LockSession;
  2714.     try
  2715.       Check(DbiSetPrivateDir(AnsiToNative(nil, Value, Buffer,
  2716.         SizeOf(Buffer) - 1)));
  2717.     finally
  2718.       UnlockSession;
  2719.     end;
  2720.   end;
  2721.   FPrivateDir := Value;
  2722. end;
  2723.  
  2724. procedure TSession.SetSessionName(const Value: string);
  2725. var
  2726.   Ses: TSession;
  2727. begin
  2728.   if FAutoSessionName and not FUpdatingAutoSessionName then DatabaseError(SAutoSessionActive);
  2729.   CheckInActive;
  2730.   if Value <> '' then
  2731.   begin
  2732.     Ses := Sessions.FindSession(Value);
  2733.     if not ((Ses = nil) or (Ses = Self)) then
  2734.       DatabaseErrorFmt(SDuplicateSessionName, [Value]);
  2735.   end;
  2736.   FSessionName := Value
  2737. end;
  2738.  
  2739. procedure TSession.SetSessionNames;
  2740. var
  2741.   I: Integer;
  2742.   Component: TComponent;
  2743. begin
  2744.   if Owner <> nil then
  2745.     for I := 0 to Owner.ComponentCount - 1 do
  2746.     begin
  2747.       Component := Owner.Components[I];
  2748.       if Component is TDBDataSet then
  2749.         TDBDataSet(Component).SessionName := Self.SessionName
  2750.       else if Component is TDataBase then
  2751.         TDataBase(Component).SessionName := Self.SessionName
  2752.     end;
  2753. end;
  2754.  
  2755. procedure TSession.SetTraceFlags(Value: TTraceFlags);
  2756. var
  2757.   I: Integer;
  2758. begin
  2759.   FTraceFlags := Value;
  2760.   for I := FDatabases.Count - 1 downto 0 do
  2761.     with TDatabase(FDatabases[I]) do
  2762.       TraceFlags := FTraceFlags;
  2763. end;
  2764.  
  2765. procedure TSession.SMClientSignal(Sender: TObject; Data: Integer);
  2766. begin
  2767.   SetTraceFlags(TTraceFlags(Word(Data)));
  2768. end;
  2769.  
  2770. function TSession.SqlTraceCallBack(CBInfo: Pointer): CBRType;
  2771. var
  2772.   Data: Pointer;
  2773. begin
  2774.   try
  2775.     Data := @PTraceDesc(CBInfo).pszTrace;
  2776.     FSMClient.AddStatement(Data, StrLen(Data));
  2777.   except
  2778.     SetTraceFlags([]);
  2779.   end;
  2780.   Result := cbrUSEDEF;
  2781. end;
  2782.  
  2783. procedure TSession.StartSession(Value: Boolean);
  2784. var
  2785.   I: Integer;
  2786. begin
  2787.   EnterCriticalSection(FCSect);
  2788.   try
  2789.     if Value then
  2790.     begin
  2791.       if Assigned(FOnStartup) then FOnStartup(Self);
  2792.       if FSessionName = '' then DatabaseError(SSessionNameMissing);
  2793.       if (DefaultSession <> Self) then DefaultSession.Active := True;
  2794.       if FDefault then
  2795.         InitializeBDE
  2796.       else
  2797.         Check(DbiStartSession(nil, FHandle, nil));
  2798.       try
  2799.         RegisterCallbacks(True);
  2800.         if FNetFileDir <> '' then SetNetFileDir(FNetFileDir);
  2801.         if FPrivateDir <> '' then SetPrivateDir(FPrivateDir);
  2802.         ConfigMode := cmAll;
  2803.         CallBDEInitProcs;
  2804.       except
  2805.         StartSession(False);
  2806.         raise;
  2807.       end;
  2808.     end else
  2809.     begin
  2810.       DbiSetCurrSession(FHandle);
  2811.       for I := FDatabases.Count - 1 downto 0 do
  2812.         with TDatabase(FDatabases[I]) do
  2813.           if Temporary then Free else Close;
  2814.       RegisterCallbacks(False);
  2815.       if FDefault then
  2816.       begin
  2817.         if not FDLLDetach then
  2818.         begin
  2819.           if IsLibrary then
  2820.           begin
  2821.             DbiRegisterCallback(nil, cbDETACHNOTIFY, 0, 0, @DLLDetachCallBack, nil);
  2822.             DbiDLLExit;
  2823.           end;
  2824.           DbiExit;
  2825.         end;
  2826.       end
  2827.       else
  2828.       begin
  2829.         Check(DbiCloseSession(FHandle));
  2830.         DbiSetCurrSession(DefaultSession.FHandle);
  2831.       end;
  2832.       FHandle := nil;
  2833.     end;
  2834.   finally
  2835.     LeaveCriticalSection(FCSect);
  2836.   end;
  2837. end;
  2838.  
  2839. procedure TSession.UpdateAutoSessionName;
  2840. begin
  2841.   FUpdatingAutoSessionName := True;
  2842.   try
  2843.     SessionName := Format('%s_%d', [Name, FSessionNumber + 1]);
  2844.   finally
  2845.     FUpdatingAutoSessionName := False;
  2846.   end;
  2847.   SetSessionNames;
  2848. end;
  2849.  
  2850. procedure TSession.ValidateAutoSession(AOwner: TComponent; AllSessions: Boolean);
  2851. var
  2852.   I: Integer;
  2853.   Component: TComponent;
  2854. begin
  2855.   if AOwner <> nil then
  2856.     for I := 0 to AOwner.ComponentCount - 1 do
  2857.     begin
  2858.       Component := AOwner.Components[I];
  2859.       if (Component <> Self) and (Component is TSession) then
  2860.         if AllSessions then DatabaseError(SAutoSessionExclusive)
  2861.         else if TSession(Component).AutoSessionName then
  2862.           DatabaseErrorFmt(SAutoSessionExists, [Component.Name]);
  2863.     end;
  2864. end;
  2865.  
  2866. { TParamList }
  2867.  
  2868. constructor TParamList.Create(Params: TStrings);
  2869. var
  2870.   I, P, FieldNo: Integer;
  2871.   BufPtr: PChar;
  2872.   S: string;
  2873. begin
  2874.   for I := 0 to Params.Count - 1 do
  2875.   begin
  2876.     S := Params[I];
  2877.     P := Pos('=', S);
  2878.     if P <> 0 then
  2879.     begin
  2880.       Inc(FFieldCount);
  2881.       Inc(FBufSize, Length(S) - P + 1);
  2882.     end;
  2883.   end;
  2884.   if FFieldCount > 0 then
  2885.   begin
  2886.     FFieldDescs := AllocMem(FFieldCount * SizeOf(FLDDesc));
  2887.     FBuffer := AllocMem(FBufSize);
  2888.     FieldNo := 0;
  2889.     BufPtr := FBuffer;
  2890.     for I := 0 to Params.Count - 1 do
  2891.     begin
  2892.       S := Params[I];
  2893.       P := Pos('=', S);
  2894.       if P <> 0 then
  2895.         with FFieldDescs^[FieldNo] do
  2896.         begin
  2897.           Inc(FieldNo);
  2898.           iFldNum := FieldNo;
  2899.           StrPLCopy(szName, Copy(S, 1, P - 1), SizeOf(szName) - 1);
  2900.           iFldType := fldZSTRING;
  2901.           iOffset := BufPtr - FBuffer;
  2902.           iLen := Length(S) - P + 1;
  2903.           StrCopy(BufPtr, PChar(Copy(S, P + 1, 255)));
  2904.           CharToOem(BufPtr, BufPtr);
  2905.           Inc(BufPtr, iLen);
  2906.         end;
  2907.     end;
  2908.   end;
  2909. end;
  2910.  
  2911. destructor TParamList.Destroy;
  2912. begin
  2913.   DisposeMem(FFieldDescs, FFieldCount * SizeOf(FLDDesc));
  2914.   DisposeMem(FBuffer, FBufSize);
  2915. end;
  2916.  
  2917. { TDatabase }
  2918.  
  2919. constructor TDatabase.Create(AOwner: TComponent);
  2920. begin
  2921.   inherited Create(AOwner);
  2922.   Exclude(FComponentStyle, csInheritable);
  2923.   if AOwner is TSession then
  2924.     FSession := TSession(AOwner) else
  2925.     FSession := DefaultSession;
  2926.   SessionName := FSession.SessionName;
  2927.   FSession.AddDatabase(Self);
  2928.   FDataSets := TList.Create;
  2929.   FParams := TStringList.Create;
  2930.   TStringList(FParams).OnChanging := ParamsChanging;
  2931.   FLoginPrompt := True;
  2932.   FKeepConnection := True;
  2933.   FLocale := FSession.Locale;
  2934.   FTransIsolation := tiReadCommitted;
  2935. end;
  2936.  
  2937. destructor TDatabase.Destroy;
  2938. begin
  2939.   Destroying;
  2940.   Close;
  2941.   FParams.Free;
  2942.   FDataSets.Free;
  2943.   if FSession <> nil then
  2944.     FSession.RemoveDatabase(Self);
  2945.   inherited Destroy;
  2946. end;
  2947.  
  2948. procedure TDatabase.ApplyUpdates(const DataSets: array of TDBDataSet);
  2949. var
  2950.   I: Integer;
  2951.   DS: TDBDataSet;
  2952. begin
  2953.   StartTransaction;
  2954.   try
  2955.     for I := 0 to High(DataSets) do
  2956.     begin
  2957.       DS := DataSets[I];
  2958.       if DS.Database <> Self then
  2959.         DatabaseError(Format(SUpdateWrongDB, [DS.Name, Name]));
  2960.       DataSets[I].ApplyUpdates;
  2961.     end;
  2962.     Commit;
  2963.   except
  2964.     Rollback;
  2965.     raise;
  2966.   end;
  2967.   for I := 0 to High(DataSets) do
  2968.     DataSets[I].CommitUpdates;
  2969. end;
  2970.  
  2971. procedure TDatabase.CheckActive;
  2972. begin
  2973.   if FHandle = nil then DatabaseError(SDatabaseClosed);
  2974. end;
  2975.  
  2976. procedure TDatabase.CheckInactive;
  2977. begin
  2978.   if FHandle <> nil then DatabaseError(SDatabaseOpen);
  2979. end;
  2980.  
  2981. procedure TDatabase.CheckDatabaseName;
  2982. begin
  2983.   if (FDatabaseName = '') and not Temporary then
  2984.     DatabaseError(SDatabaseNameMissing);
  2985. end;
  2986.  
  2987. procedure TDatabase.CheckSessionName(Required: Boolean);
  2988. var
  2989.   NewSession: TSession;
  2990. begin
  2991.   if Required then
  2992.     NewSession := Sessions.List[FSessionName]
  2993.   else
  2994.     NewSession := Sessions.FindSession(FSessionName);
  2995.   if (NewSession <> nil) and (NewSession <> FSession) then
  2996.   begin
  2997.     if (FSession <> nil) then FSession.RemoveDatabase(Self);
  2998.     FSession := NewSession;
  2999.     FSession.AddDatabase(Self);
  3000.     try
  3001.       ValidateName(FDatabaseName);
  3002.     except
  3003.       FDatabaseName := '';
  3004.       raise;
  3005.     end;
  3006.   end;
  3007.   if Required then FSession.Active := True;
  3008. end;
  3009.  
  3010. procedure TDatabase.Close;
  3011. begin
  3012.   if FHandle <> nil then
  3013.   begin
  3014.     Session.DBNotification(dbClose, Self);
  3015.     CloseDataSets;
  3016.     if FLocaleLoaded then OsLdUnloadObj(FLocale);
  3017.     FLocaleLoaded := False;
  3018.     FLocale := DefaultSession.Locale;
  3019.     if not FAcquiredHandle then
  3020.       DbiCloseDatabase(FHandle)
  3021.     else
  3022.       FAcquiredHandle := False;
  3023.     FSQLBased := False;
  3024.     FHandle := nil;
  3025.     FRefCount := 0;
  3026.     if FSessionAlias then
  3027.     begin
  3028.       FSession.InternalDeleteAlias(FDatabaseName, cmSession, True);
  3029.       FSessionAlias := False;
  3030.     end;
  3031.   end;
  3032. end;
  3033.  
  3034. procedure TDatabase.CloseDataSets;
  3035. begin
  3036.   while FDataSets.Count <> 0 do TDBDataSet(FDataSets.Last).Disconnect;
  3037. end;
  3038.  
  3039. procedure TDatabase.Commit;
  3040. begin
  3041.   CheckActive;
  3042.   EndTransaction(xendCOMMIT);
  3043. end;
  3044.  
  3045. procedure TDatabase.EndTransaction(TransEnd: EXEnd);
  3046. begin
  3047.   Check(DbiEndTran(FHandle, nil, TransEnd));
  3048. end;
  3049.  
  3050. function TDatabase.GetAliasName: string;
  3051. begin
  3052.   if FAliased then Result := FDatabaseType else Result := '';
  3053. end;
  3054.  
  3055. function TDatabase.GetConnected: Boolean;
  3056. begin
  3057.   Result := FHandle <> nil;
  3058. end;
  3059.  
  3060. function TDatabase.GetDataSet(Index: Integer): TDBDataSet;
  3061. begin
  3062.   Result := FDataSets[Index];
  3063. end;
  3064.  
  3065. function TDatabase.GetDataSetCount: Integer;
  3066. begin
  3067.   Result := FDataSets.Count;
  3068. end;
  3069.  
  3070. function TDatabase.GetDirectory: string;
  3071. var
  3072.   SDirectory: DBIPATH;
  3073. begin
  3074.   if Handle <> nil then
  3075.   begin
  3076.     Check(DbiGetDirectory(Handle, False, SDirectory));
  3077.     SetLength(Result, StrLen(SDirectory));
  3078.     OemToChar(SDirectory, PChar(Result));
  3079.   end else
  3080.     Result := '';
  3081. end;
  3082.  
  3083. function TDatabase.GetDriverName: string;
  3084. begin
  3085.   if FAliased then Result := '' else Result := FDatabaseType;
  3086. end;
  3087.  
  3088. function TDatabase.GetIsSQLBased: Boolean;
  3089. var
  3090.   Length: Word;
  3091.   Buffer: array[0..63] of Char;
  3092. begin
  3093.   Result := False;
  3094.   if FHandle <> nil then
  3095.   begin
  3096.     Check(DbiGetProp(HDBIOBJ(FHandle), dbDATABASETYPE, @Buffer,
  3097.       SizeOf(Buffer), Length));
  3098.     Result := StrIComp(Buffer, szCFGDBSTANDARD) <> 0;
  3099.   end;
  3100. end;
  3101.  
  3102. function TDatabase.GetTraceFlags: TTraceFlags;
  3103. begin
  3104.   if Connected and IsSQLBased then
  3105.     Result := TTraceFlags(Word(GetIntProp(FHandle, dbTraceMode)))
  3106.   else
  3107.     Result := [];
  3108. end;
  3109.  
  3110. function TDatabase.GetInTransaction: Boolean;
  3111. var
  3112.   X: XInfo;
  3113. begin
  3114.   Result := (Handle <> nil) and (DbiGetTranInfo(Handle, nil, @X) = DBIERR_NONE)
  3115.     and (X.exState = xsActive);
  3116. end;
  3117.  
  3118. procedure TDatabase.Loaded;
  3119. begin
  3120.   inherited Loaded;
  3121.   try
  3122.     if FStreamedConnected then Open
  3123.     else CheckSessionName(False);
  3124.   except
  3125.     if csDesigning in ComponentState then
  3126.       Application.HandleException(Self)
  3127.     else
  3128.       raise;
  3129.   end;
  3130. end;
  3131.  
  3132. procedure TDatabase.Notification(AComponent: TComponent; Operation: TOperation);
  3133. begin
  3134.   inherited Notification(AComponent, Operation);
  3135.   if (Operation = opRemove) and (AComponent = FSession) and
  3136.     (FSession <> DefaultSession) then
  3137.     FSession := nil;
  3138. end;
  3139.  
  3140. procedure TDatabase.LoadLocale;
  3141. var
  3142.   LName: DBIName;
  3143.   DBLocale: TLocale;
  3144. begin
  3145.   if IsSQLBased and (DbiGetLdNameFromDB(FHandle, nil, LName) = 0) and
  3146.     (OsLdLoadBySymbName(LName, DBLocale) = 0) then
  3147.   begin
  3148.     FLocale := DBLocale;
  3149.     FLocaleLoaded := True;
  3150.   end;
  3151. end;
  3152.  
  3153. procedure TDatabase.Login(LoginParams: TStrings);
  3154. var
  3155.   UserName, Password: string;
  3156. begin
  3157.   if Assigned(FOnLogin) then FOnLogin(Self, LoginParams) else
  3158.   begin
  3159.     UserName := LoginParams.Values[szUSERNAME];
  3160.     if not LoginDialogEx(DatabaseName, UserName, Password, False) then
  3161.       DatabaseErrorFmt(SLoginError, [DatabaseName]);
  3162.     LoginParams.Values[szUSERNAME] := UserName;
  3163.     LoginParams.Values[szPASSWORD] := Password;
  3164.   end;
  3165. end;
  3166.  
  3167. procedure TDatabase.CheckDatabaseAlias(var Password: string);
  3168. var
  3169.   Desc: DBDesc;
  3170.   Aliased: Boolean;
  3171.   DBName: string;
  3172.   DriverType: string;
  3173.   AliasParams: TStringList;
  3174.   LoginParams: TStringList;
  3175.  
  3176.   function NeedsDBAlias: Boolean;
  3177.   var
  3178.     I: Integer;
  3179.     PName: String;
  3180.   begin
  3181.     Result := not Aliased or ((FDatabaseType <> '') and
  3182.       (FDatabaseName <> FDatabaseType));
  3183.     for I := 0 to FParams.Count - 1 do
  3184.     begin
  3185.       if AliasParams.IndexOf(FParams[I]) > -1 then continue;
  3186.       PName := FParams.Names[I];
  3187.       if (CompareText(PName, szPASSWORD) = 0) then continue;
  3188.       if AliasParams.IndexOfName(PName) > -1 then
  3189.       begin
  3190.         Result := True;
  3191.         AliasParams.Values[PName] := FParams.Values[PName];
  3192.       end;
  3193.     end;
  3194.   end;
  3195.  
  3196. begin
  3197.   Password := '';
  3198.   FSessionAlias := False;
  3199.   AliasParams := TStringList.Create;
  3200.   try
  3201.     begin
  3202.       if FDatabaseType <> '' then
  3203.       begin
  3204.         DBName := FDatabaseType;
  3205.         Aliased := FAliased;
  3206.       end else
  3207.       begin
  3208.         DBName := FDatabaseName;
  3209.         Aliased := True;
  3210.       end;
  3211.       if Aliased then
  3212.       begin
  3213.         if DbiGetDatabaseDesc(PChar(StrToOem(DBName)), @Desc) <> 0 then Exit;
  3214.         if Desc.szDBType[sizeOf(Desc.szDBType) - 1] <> #0 then
  3215.           Desc.szDBType[sizeOf(Desc.szDBType) - 1] := #0;
  3216.         OemToChar(Desc.szDbType, Desc.szDbType);
  3217.         DriverType := Desc.szDbType;
  3218.         FSession.GetAliasParams(DBName, AliasParams);
  3219.       end else
  3220.       begin
  3221.         FSession.GetDriverParams(DBName, AliasParams);
  3222.         DriverType := FDatabaseType;
  3223.       end;
  3224.       if AliasParams.IndexOfName(szUSERNAME) <> -1 then
  3225.       begin
  3226.         if LoginPrompt then
  3227.         begin
  3228.           LoginParams := TStringList.Create;
  3229.           try
  3230.             if FParams.Values[szUSERNAME] = '' then
  3231.               FParams.Values[szUSERNAME] := AliasParams.Values[szUSERNAME];
  3232.             LoginParams.Values[szUSERNAME] := FParams.Values[szUSERNAME];
  3233.             Login(LoginParams);
  3234.             Password := LoginParams.Values[szPASSWORD];
  3235.             FParams.Values[szUSERNAME] := LoginParams.Values[szUSERNAME];
  3236.           finally
  3237.             LoginParams.Free;
  3238.           end;
  3239.         end else
  3240.           Password := FParams.Values[szPASSWORD];
  3241.       end;
  3242.     end;
  3243.     if NeedsDBAlias then
  3244.     begin
  3245.       FSession.InternalAddAlias(FDatabaseName, DriverType, AliasParams,
  3246.         cmSession, False);
  3247.       FSessionAlias := True;
  3248.     end;
  3249.   finally
  3250.     AliasParams.Free;
  3251.   end;
  3252. end;
  3253.  
  3254. procedure TDatabase.Open;
  3255. var
  3256.   DBName: string;
  3257.   DBPassword: string;
  3258.   CfgModeSave: TConfigMode;
  3259. begin
  3260.   if FHandle = nil then
  3261.   begin
  3262.     CheckDatabaseName;
  3263.     CheckSessionName(True);
  3264.     FSession.LockSession;
  3265.     try
  3266.       CfgModeSave := FSession.ConfigMode;
  3267.       try
  3268.         CheckDatabaseAlias(DBPassword);
  3269.         try
  3270.           if (FDatabaseType = '') and IsDirectory(FDatabaseName) then
  3271.             DBName := '' else
  3272.             DBName := StrToOem(FDatabaseName);
  3273.           Check(DbiOpenDatabase(Pointer(DBName), nil, dbiREADWRITE, dbiOPENSHARED,
  3274.             Pointer(StrToOem(DBPassword)), 0, nil, nil, FHandle));
  3275.           if DBName = '' then SetDirectory(FDatabaseName);
  3276.           DbiSetProp(HDBIOBJ(FHandle), dbUSESCHEMAFILE, Longint(True));
  3277.           DbiSetProp(HDBIOBJ(FHandle), dbPARAMFMTQMARK, Longint(True));
  3278.           FSQLBased := GetIsSQLBased;
  3279.           LoadLocale;
  3280.           if IsSQLBased then FSession.LoadSMClient;
  3281.           TraceFlags := FSession.FTraceFlags;
  3282.           Session.DBNotification(dbOpen, Self);
  3283.         except
  3284.           if FSessionAlias then
  3285.             FSession.InternalDeleteAlias(FDatabaseName, cmSession, False);
  3286.           raise;
  3287.         end;
  3288.       finally
  3289.         FSession.ConfigMode := CfgModeSave;
  3290.       end;
  3291.     finally
  3292.       FSession.UnlockSession;
  3293.     end;
  3294.   end;
  3295. end;
  3296.  
  3297. procedure TDatabase.ParamsChanging(Sender: TObject);
  3298. begin
  3299.   CheckInactive;
  3300. end;
  3301.  
  3302. procedure TDatabase.Rollback;
  3303. begin
  3304.   CheckActive;
  3305.   EndTransaction(xendABORT);
  3306. end;
  3307.  
  3308. procedure TDatabase.SetAliasName(const Value: string);
  3309. begin
  3310.   SetDatabaseType(Value, True);
  3311. end;
  3312.  
  3313. procedure TDatabase.SetConnected(Value: Boolean);
  3314. begin
  3315.   if csReading in ComponentState then
  3316.     FStreamedConnected := Value
  3317.   else
  3318.     if Value then Open else Close;
  3319. end;
  3320.  
  3321. procedure TDatabase.SetDatabaseName(const Value: string);
  3322. begin
  3323.   if csReading in ComponentState then
  3324.     FDatabaseName := Value else
  3325.   if FDatabaseName <> Value then
  3326.   begin
  3327.     CheckInactive;
  3328.     ValidateName(Value);
  3329.     FDatabaseName := Value;
  3330.   end;
  3331. end;
  3332.  
  3333. procedure TDatabase.SetDatabaseType(const Value: string;
  3334.   Aliased: Boolean);
  3335. begin
  3336.   CheckInactive;
  3337.   FDatabaseType := Value;
  3338.   FAliased := Aliased;
  3339. end;
  3340.  
  3341. procedure TDatabase.SetDirectory(const Value: string);
  3342. begin
  3343.   if Handle <> nil then
  3344.     Check(DbiSetDirectory(Handle, Pointer(StrToOem(Value))));
  3345. end;
  3346.  
  3347. procedure TDatabase.SetDriverName(const Value: string);
  3348. begin
  3349.   SetDatabaseType(Value, False);
  3350. end;
  3351.  
  3352. procedure TDatabase.SetHandle(Value: HDBIDB);
  3353. var
  3354.   DBSession: HDBISes;
  3355. begin
  3356.   if Connected then Close;
  3357.   if Value <> nil then
  3358.   begin
  3359.     Check(DbiGetObjFromObj(HDBIObj(Value), objSESSION, HDBIObj(DBSession)));
  3360.     CheckDatabaseName;
  3361.     CheckSessionName(True);
  3362.     if FSession.Handle <> DBSession then DatabaseError(SDatabaseHandleSet);
  3363.     FHandle := Value;
  3364.     FSQLBased := GetIsSQLBased;
  3365.     LoadLocale;
  3366.     Session.DBNotification(dbOpen, Self);
  3367.     FAcquiredHandle := True;
  3368.   end;
  3369. end;
  3370.  
  3371. procedure TDatabase.SetKeepConnection(Value: Boolean);
  3372. begin
  3373.   if FKeepConnection <> Value then
  3374.   begin
  3375.     FKeepConnection := Value;
  3376.     if not Value and (FRefCount = 0) then Close;
  3377.   end;
  3378. end;
  3379.  
  3380. procedure TDatabase.SetParams(Value: TStrings);
  3381. begin
  3382.   CheckInactive;
  3383.   FParams.Assign(Value);
  3384. end;
  3385.  
  3386. procedure TDatabase.SetSessionName(const Value: string);
  3387. begin
  3388.   CheckInactive;
  3389.   if FSessionName <> Value then
  3390.   begin
  3391.     FSessionName := Value;
  3392.     CheckSessionName(False);
  3393.   end;
  3394. end;
  3395.  
  3396. procedure TDatabase.SetTraceFlags(Value: TTraceFlags);
  3397. begin
  3398.   if Connected and IsSQLBased then
  3399.     DbiSetProp(hDBIObj(FHandle), dbTraceMode, Integer(Word(Value)));
  3400. end;
  3401.  
  3402. procedure TDatabase.StartTransaction;
  3403. var
  3404.   TransHandle:  HDBIXAct;
  3405. begin
  3406.   CheckActive;
  3407.   if not IsSQLBased and (TransIsolation <> tiDirtyRead) then
  3408.     DatabaseError(SLocalTransDirty);
  3409.   Check(DbiBeginTran(FHandle, EXILType(FTransIsolation), TransHandle));
  3410. end;
  3411.  
  3412. procedure TDatabase.ValidateName(const Name: string);
  3413. var
  3414.   Database: TDatabase;
  3415. begin
  3416.   if (Name <> '') and (FSession <> nil) then
  3417.   begin
  3418.     Database := FSession.FindDatabase(Name);
  3419.     if (Database <> nil) and (Database <> Self) then
  3420.     begin
  3421.       if not Database.Temporary or (Database.FRefCount <> 0) then
  3422.         DatabaseErrorFmt(SDuplicateDatabaseName, [Name]);
  3423.       Database.Free;
  3424.     end;
  3425.   end;
  3426. end;
  3427.  
  3428. procedure TDatabase.FlushSchemaCache(const TableName: string);
  3429. begin
  3430.   if Connected and IsSQLBased then
  3431.     Check(DbiSchemaCacheFlush(FHandle, PChar(TableName)));
  3432. end;
  3433.  
  3434. { TBDEDataSet }
  3435.  
  3436. constructor TBDEDataSet.Create(AOwner: TComponent);
  3437. begin
  3438.   inherited Create(AOwner);
  3439.   SetLocale(DefaultSession.Locale);
  3440.   FCacheBlobs := True;
  3441. end;
  3442.  
  3443. destructor TBDEDataSet.Destroy;
  3444. begin
  3445.   inherited Destroy;
  3446.   FAsyncCallback.Free; { ! this is also in CloseCursor }
  3447.   SetUpdateObject(nil);
  3448. end;
  3449.  
  3450. procedure TBDEDataSet.OpenCursor(InfoQuery: Boolean);
  3451. var
  3452.   CursorLocale: TLocale;
  3453. begin
  3454.   if not InfoQuery and (FAsyncCallback = nil) then
  3455.     FAsyncCallback := TBDECallback.Create(Self, nil, cbYIELDCLIENT,
  3456.       @FCBYieldStep, SizeOf(CBYieldStep), YieldCallBack, False);
  3457.   FHandle := CreateHandle;
  3458.   if FHandle = nil then raise ENoResultSet.Create(SHandleError);
  3459.   if DbiGetLdObj(FHandle, CursorLocale) = 0 then SetLocale(CursorLocale);
  3460.   inherited OpenCursor(InfoQuery);
  3461. end;
  3462.  
  3463. procedure TBDEDataSet.CloseCursor;
  3464. begin
  3465.   inherited CloseCursor;
  3466.   SetLocale(DefaultSession.Locale);
  3467.   FAsyncCallback.Free;
  3468.   FAsyncCallback := nil;
  3469.   if FHandle <> nil then
  3470.   begin
  3471.     DestroyHandle;
  3472.     FHandle := nil;
  3473.   end;
  3474. end;
  3475.  
  3476. function TBDEDataSet.CreateHandle: HDBICur;
  3477. begin
  3478.   Result := nil;
  3479. end;
  3480.  
  3481. procedure TBDEDataSet.DestroyHandle;
  3482. begin
  3483.   DbiRelRecordLock(FHandle, False);
  3484.   DbiCloseCursor(FHandle);
  3485. end;
  3486.  
  3487. procedure TBDEDataSet.InternalInitFieldDefs;
  3488. var
  3489.   I: Integer;
  3490.   FieldDescs: PFieldDescList;
  3491.   ValCheckDesc: VCHKDesc;
  3492.   RequiredFields: set of 0..255;
  3493.   CursorProps: CurProps;
  3494. begin
  3495.   DbiGetCursorProps(FHandle, CursorProps);
  3496.   RequiredFields := [];
  3497.   for I := 1 to CursorProps.iValChecks do
  3498.   begin
  3499.     DbiGetVChkDesc(FHandle, I, @ValCheckDesc);
  3500.     if ValCheckDesc.bRequired and not ValCheckDesc.bHasDefVal then
  3501.       Include(RequiredFields, ValCheckDesc.iFldNum - 1);
  3502.   end;
  3503.   FieldDescs := AllocMem(CursorProps.iFields * SizeOf(FLDDesc));
  3504.   try
  3505.     DbiGetFieldDescs(FHandle, PFLDDesc(FieldDescs));
  3506.     FieldDefs.Clear;
  3507.     for I := 0 to CursorProps.iFields - 1 do
  3508.       AddFieldDesc(FieldDescs^[I], I in RequiredFields, I + 1);
  3509.   finally
  3510.     FreeMem(FieldDescs, CursorProps.iFields * SizeOf(FLDDesc));
  3511.   end;
  3512. end;
  3513.  
  3514. procedure TBDEDataSet.InternalOpen;
  3515. var
  3516.   CursorProps: CurProps;
  3517. begin
  3518.   if CachedUpdates then Check(DbiBeginDelayedUpdates(FHandle));
  3519.   if HasConstraints then
  3520.   begin
  3521.     { ! Nuke this if you can, ask Rick... }
  3522.     if not Assigned(FConstraintsDB) then
  3523.       Check(DbiOpenDatabase(nil, nil, dbiREADWRITE, dbiOPENSHARED,
  3524.           nil, 0, nil, nil, FConstraintsDB));
  3525.     Check(DbiBeginConstraintLayer(FConstraintsDB, FHandle,
  3526.       @TBDEDataSet.ConstraintCallBack, Integer(Pointer(Self))));
  3527.   end;
  3528.   DbiGetCursorProps(FHandle, CursorProps);
  3529.   FRecordSize := CursorProps.iRecBufSize;
  3530.   BookmarkSize := CursorProps.iBookmarkSize;
  3531.   FCanModify := (CursorProps.eOpenMode = dbiReadWrite)
  3532.     and not CursorProps.bTempTable;
  3533.   FRecNoStatus := TRecNoStatus(CursorProps.ISeqNums);
  3534.   InternalInitFieldDefs;
  3535.   GetIndexInfo;
  3536.   if DefaultFields then CreateFields;
  3537.   BindFields(True);
  3538.   InitBufferPointers(False);
  3539.   if CachedUpdates then
  3540.   begin
  3541.     AllocCachedUpdateBuffers(True);
  3542.     SetupCallBack(UpdateCallBackRequired);
  3543.   end;
  3544.   AllocKeyBuffers;
  3545.   DbiSetToBegin(FHandle);
  3546.   PrepareCursor;
  3547.   if Filter <> '' then
  3548.     FExprFilter := CreateExprFilter(Filter, FilterOptions, 0);
  3549.   if Assigned(OnFilterRecord) then
  3550.     FFuncFilter := CreateFuncFilter(@TBDEDataSet.RecordFilter, 1);
  3551.   if Filtered then ActivateFilters;
  3552. end;
  3553.  
  3554. procedure TBDEDataSet.InternalClose;
  3555. begin
  3556.   FFuncFilter := nil;
  3557.   FExprFilter := nil;
  3558.   FreeKeyBuffers;
  3559.   if CachedUpdates then
  3560.   begin
  3561.     SetupCallBack(False);
  3562.     AllocCachedUpdateBuffers(False);
  3563.     if HasConstraints then DbiEndConstraintLayer(FHandle);
  3564.     DbiEndDelayedUpdates(FHandle);
  3565.   end;
  3566.   BindFields(False);
  3567.   if DefaultFields then DestroyFields;
  3568.   FIndexFieldCount := 0;
  3569.   FKeySize := 0;
  3570.   FExpIndex := False;
  3571.   FCaseInsIndex := False;
  3572.   FCanModify := False;
  3573. end;
  3574.  
  3575. procedure TBDEDataSet.PrepareCursor;
  3576. begin
  3577. end;
  3578.  
  3579. function TBDEDataSet.IsCursorOpen: Boolean;
  3580. begin
  3581.   Result := Handle <> nil;
  3582. end;
  3583.  
  3584. procedure TBDEDataSet.InternalHandleException;
  3585. begin
  3586.   Application.HandleException(Self)
  3587. end;
  3588.  
  3589. procedure TBDEDataSet.SetLocale(Value: TLocale);
  3590. begin
  3591.   FLocale := Value;
  3592. end;
  3593.  
  3594. { Record Functions }
  3595.  
  3596. procedure TBDEDataSet.InitBufferPointers(GetProps: Boolean);
  3597. var
  3598.   CursorProps: CurProps;
  3599. begin
  3600.   if GetProps then
  3601.   begin
  3602.     Check(DbiGetCursorProps(FHandle, CursorProps));
  3603.     BookmarkSize := CursorProps.iBookmarkSize;
  3604.     FRecordSize := CursorProps.iRecBufSize;
  3605.   end;
  3606.   FBlobCacheOfs := FRecordSize + CalcFieldsSize;
  3607.   FRecInfoOfs := FBlobCacheOfs + BlobFieldCount * SizeOf(Pointer);
  3608.   FBookmarkOfs := FRecInfoOfs + SizeOf(TRecInfo);
  3609.   FRecBufSize := FBookmarkOfs + BookmarkSize;
  3610. end;
  3611.  
  3612. function TBDEDataSet.AllocRecordBuffer: PChar;
  3613. begin
  3614.   Result := StrAlloc(FRecBufSize);
  3615.   if BlobFieldCount > 0 then
  3616.     Initialize(PBlobDataArray(Result + FBlobCacheOfs)[0], BlobFieldCount);
  3617. end;
  3618.  
  3619. procedure TBDEDataSet.FreeRecordBuffer(var Buffer: PChar);
  3620. begin
  3621.   if BlobFieldCount > 0 then
  3622.     Finalize(PBlobDataArray(Buffer + FBlobCacheOfs)[0], BlobFieldCount);
  3623.   StrDispose(Buffer);
  3624. end;
  3625.  
  3626. procedure TBDEDataSet.InternalInitRecord(Buffer: PChar);
  3627. begin
  3628.   DbiInitRecord(FHandle, Buffer);
  3629. end;
  3630.  
  3631. procedure TBDEDataSet.ClearBlobCache(Buffer: PChar);
  3632. var
  3633.   I: Integer;
  3634. begin
  3635.   if FCacheBlobs then
  3636.     for I := 0 to BlobFieldCount - 1 do
  3637.       PBlobDataArray(Buffer + FBlobCacheOfs)[I] := '';
  3638. end;
  3639.  
  3640. procedure TBDEDataSet.ClearCalcFields(Buffer: PChar);
  3641. begin
  3642.   FillChar(Buffer[RecordSize], CalcFieldsSize, 0);
  3643. end;
  3644.  
  3645. procedure TBDEDataSet.InitRecord(Buffer: PChar);
  3646. begin
  3647.   inherited InitRecord(Buffer);
  3648.   ClearBlobCache(Buffer);
  3649.   with PRecInfo(Buffer + FRecInfoOfs)^ do
  3650.   begin
  3651.     UpdateStatus := TUpdateStatus(usInserted);
  3652.     BookMarkFlag := bfInserted;
  3653.     RecordNumber := -1;
  3654.   end;
  3655. end;
  3656.  
  3657. function TBDEDataSet.GetRecord(Buffer: PChar; GetMode: TGetMode;
  3658.   DoCheck: Boolean): TGetResult;
  3659. var
  3660.   Status: DBIResult;
  3661. begin
  3662.   case GetMode of
  3663.     gmCurrent:
  3664.       Status := DbiGetRecord(FHandle, dbiNoLock, Buffer, @FRecProps);
  3665.     gmNext:
  3666.       Status := DbiGetNextRecord(FHandle, dbiNoLock, Buffer, @FRecProps);
  3667.     gmPrior:
  3668.       Status := DbiGetPriorRecord(FHandle, dbiNoLock, Buffer, @FRecProps);
  3669.   else
  3670.     Status := DBIERR_NONE;
  3671.   end;
  3672.   case Status of
  3673.     DBIERR_NONE:
  3674.       begin
  3675.         with PRecInfo(Buffer + FRecInfoOfs)^ do
  3676.         begin
  3677.           UpdateStatus := TUpdateStatus(FRecProps.iRecStatus);
  3678.           BookmarkFlag := bfCurrent;
  3679.           case FRecNoStatus of
  3680.             rnParadox: RecordNumber := FRecProps.iSeqNum;
  3681.             rnDBase: RecordNumber := FRecProps.iPhyRecNum;
  3682.           else
  3683.             RecordNumber := -1;
  3684.           end;
  3685.         end;
  3686.         ClearBlobCache(Buffer);
  3687.         GetCalcFields(Buffer);
  3688.         Check(DbiGetBookmark(FHandle, Buffer + FBookmarkOfs));
  3689.         Result := grOK;
  3690.       end;
  3691.     DBIERR_BOF: Result := grBOF;
  3692.     DBIERR_EOF: Result := grEOF;
  3693.   else
  3694.     Result := grError;
  3695.     if DoCheck then Check(Status);
  3696.   end;
  3697. end;
  3698.  
  3699. function TBDEDataSet.GetCurrentRecord(Buffer: PChar): Boolean;
  3700. begin
  3701.   if not IsEmpty and (GetBookmarkFlag(ActiveBuffer) = bfCurrent) then
  3702.   begin
  3703.     UpdateCursorPos;
  3704.     Result := (DbiGetRecord(FHandle, dbiNoLock, Buffer, nil) = DBIERR_NONE);
  3705.   end else
  3706.     Result := False;
  3707. end;
  3708.  
  3709. function TBDEDataSet.GetOldRecord: PChar;
  3710. begin
  3711.   UpdateCursorPos;
  3712.   Check(DbiSetProp(hDbiObj(Handle), curDELAYUPDGETOLDRECORD, Longint(True)));
  3713.   try
  3714.     Check(DbiGetRecord(FHandle, dbiNoLock, FUpdateCBBuf.pOldRecBuf, nil));
  3715.   finally
  3716.     DbiSetProp(hDbiObj(Handle), curDELAYUPDGETOLDRECORD, Longint(False));
  3717.   end;
  3718.   Result := FUpdateCBBuf.pOldRecBuf;
  3719. end;
  3720.  
  3721. procedure TBDEDataSet.FetchAll;
  3722. begin
  3723.   if not EOF then
  3724.   begin
  3725.     CheckBrowseMode;
  3726.     Check(DbiSetToEnd(Handle));
  3727.     Check(DbiGetPriorRecord(FHandle, dbiNoLock, nil, nil));
  3728.     UpdateCursorPos;
  3729.   end;
  3730. end;
  3731.  
  3732. function TBDEDataSet.GetRecordCount: Integer;
  3733. begin
  3734.   CheckActive;
  3735.   Check(DbiGetExactRecordCount(FHandle, Result));
  3736. end;
  3737.  
  3738. function TBDEDataSet.GetRecNo: Integer;
  3739. var
  3740.   BufPtr: PChar;
  3741. begin
  3742.   CheckActive;
  3743.   if State = dsCalcFields then
  3744.     BufPtr := CalcBuffer else
  3745.     BufPtr := ActiveBuffer;
  3746.   Result := PRecInfo(BufPtr + FRecInfoOfs).RecordNumber;
  3747. end;
  3748.  
  3749. function TBDEDataSet.GetRecordSize: Word;
  3750. begin
  3751.   Result := FRecordSize;
  3752. end;
  3753.  
  3754. function TBDEDataSet.GetActiveRecBuf(var RecBuf: PChar): Boolean;
  3755. begin
  3756.   case State of
  3757.     dsBrowse: if IsEmpty then RecBuf := nil else RecBuf := ActiveBuffer;
  3758.     dsEdit, dsInsert: RecBuf := ActiveBuffer;
  3759.     dsSetKey: RecBuf := PChar(FKeyBuffer) + SizeOf(TKeyBuffer);
  3760.     dsCalcFields: RecBuf := CalcBuffer;
  3761.     dsFilter: RecBuf := FFilterBuffer;
  3762.     dsNewValue: if FInUpdateCallback then
  3763.                   RecBuf := FUpdateCBBuf.pNewRecBuf else
  3764.                   RecBuf := ActiveBuffer;
  3765.     dsOldValue: if FInUpdateCallback then
  3766.                   RecBuf := FUpdateCBBuf.pOldRecBuf else
  3767.                   RecBuf := GetOldRecord;
  3768.   else
  3769.     RecBuf := nil;
  3770.   end;
  3771.   Result := RecBuf <> nil;
  3772. end;
  3773.  
  3774. { Field Related }
  3775.  
  3776. procedure TBDEDataSet.AddFieldDesc(FieldDesc: FLDDesc; Required: Boolean;
  3777.   FieldNo: Word);
  3778. var
  3779.   DataType: TFieldType;
  3780.   Size: Word;
  3781.   I: Integer;
  3782.   FieldName, Name: string;
  3783. begin
  3784.   with FieldDesc do
  3785.   begin
  3786.     NativeToAnsi(Locale, szName, FieldName);
  3787.     I := 0;
  3788.     Name := FieldName;
  3789.     while FieldDefs.IndexOf(Name) >= 0 do
  3790.     begin
  3791.       Inc(I);
  3792.       Name := Format('%s_%d', [FieldName, I]);
  3793.     end;
  3794.     if iFldType < MAXLOGFLDTYPES then
  3795.       DataType := DataTypeMap[iFldType] else
  3796.       DataType := ftUnknown;
  3797.     Size := 0;
  3798.     case iFldType of
  3799.       fldZSTRING:
  3800.         Size := iUnits1;
  3801.       fldINT16, fldUINT16:
  3802.         if iLen <> 2 then DataType := ftUnknown;
  3803.       fldINT32:
  3804.         if iSubType = fldstAUTOINC then DataType := ftAutoInc;
  3805.       fldFLOAT:
  3806.         if iSubType = fldstMONEY then DataType := ftCurrency;
  3807.       fldBCD:
  3808.         Size := Abs(iUnits2);
  3809.       fldBYTES, fldVARBYTES:
  3810.         Size := iUnits1;
  3811.       fldBLOB:
  3812.         begin
  3813.           Size := iUnits1;
  3814.           if (iSubType >= fldstMEMO) and (iSubType <= fldstTYPEDBINARY) then
  3815.             DataType := BlobTypeMap[iSubType];
  3816.         end;
  3817.     end;
  3818.     if DataType <> ftUnknown then
  3819.       with TFieldDef.Create(FieldDefs, Name, DataType, Size, Required, FieldNo) do
  3820.         InternalCalcField := bCalcField;
  3821.   end;
  3822. end;
  3823.  
  3824. function TBDEDataSet.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
  3825. var
  3826.   IsBlank: LongBool;
  3827.   RecBuf: PChar;
  3828. begin
  3829.   Result := False;
  3830.   if not GetActiveRecBuf(RecBuf) then Exit;
  3831.   with Field do
  3832.     if FieldNo > 0 then
  3833.     begin
  3834.       Check(DbiGetField(FHandle, FieldNo, RecBuf, Buffer, IsBlank));
  3835.       Result := not IsBlank;
  3836.     end
  3837.     else
  3838.       if State in [dsBrowse, dsEdit, dsInsert, dsCalcFields] then
  3839.       begin
  3840.         Inc(RecBuf, FRecordSize + Offset);
  3841.         Result := Boolean(RecBuf[0]);
  3842.         if Result and (Buffer <> nil) then
  3843.           Move(RecBuf[1], Buffer^, DataSize);
  3844.       end;
  3845. end;
  3846.  
  3847. procedure TBDEDataSet.SetFieldData(Field: TField; Buffer: Pointer);
  3848. var
  3849.   RecBuf: PChar;
  3850. begin
  3851.   with Field do
  3852.   begin
  3853.     if not (State in dsWriteModes) then DatabaseError(SNotEditing);
  3854.     if (State = dsSetKey) and ((FieldNo < 0) or (FIndexFieldCount > 0) and
  3855.       not IsIndexField) then DatabaseErrorFmt(SNotIndexField, [DisplayName]);
  3856.     GetActiveRecBuf(RecBuf);
  3857.     if FieldNo > 0 then
  3858.     begin
  3859.       if State = dsCalcFields then DatabaseError(SNotEditing);
  3860.       if ReadOnly and not (State in [dsSetKey, dsFilter]) then
  3861.         DatabaseErrorFmt(SFieldReadOnly, [DisplayName]);
  3862.       Validate(Buffer);
  3863.       if FieldKind <> fkInternalCalc then
  3864.       begin
  3865. { !     Check(DbiVerifyField(FHandle, FieldNo, Buffer, Blank)); }
  3866.         Check(DbiPutField(FHandle, FieldNo, RecBuf, Buffer));
  3867.       end;
  3868.     end else {fkCalculated, fkLookup}
  3869.     begin
  3870.       Inc(RecBuf, FRecordSize + Offset);
  3871.       Boolean(RecBuf[0]) := LongBool(Buffer);
  3872.       if Boolean(RecBuf[0]) then Move(Buffer^, RecBuf[1], DataSize);
  3873.     end;
  3874.     if not (State in [dsCalcFields, dsFilter, dsNewValue]) then
  3875.       DataEvent(deFieldChange, Longint(Field));
  3876.   end;
  3877. end;
  3878.  
  3879. function TBDEDataSet.GetBlobData(Field: TField; Buffer: PChar): TBlobData;
  3880. begin
  3881.   Result := PBlobDataArray(Buffer + FBlobCacheOfs)[Field.Offset];
  3882. end;
  3883.  
  3884. procedure TBDEDataSet.SetBlobData(Field: TField; Buffer: PChar; Value: TBlobData);
  3885. begin
  3886.   if Buffer = ActiveBuffer then
  3887.     PBlobDataArray(Buffer + FBlobCacheOfs)[Field.Offset] := Value;
  3888. end;
  3889.  
  3890. function TBDEDataSet.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream;
  3891. begin
  3892.   Result := TBlobStream.Create(Field as TBlobField, Mode);
  3893. end;
  3894.  
  3895. procedure TBDEDataSet.CloseBlob(Field: TField);
  3896. begin
  3897.   DbiFreeBlob(Handle, ActiveBuffer, Field.FieldNo);
  3898. end;
  3899.  
  3900. function TBDEDataSet.BCDToCurr(BCD: Pointer; var Curr: Currency): Boolean;
  3901. begin
  3902.   Result := FMTBCDToCurr(FMTBCD(BCD^), Curr);
  3903. end;
  3904.  
  3905. function TBDEDataSet.CurrToBCD(const Curr: Currency; BCD: Pointer; Precision,
  3906.   Decimals: Integer): Boolean;
  3907. begin
  3908.   Result := CurrToFMTBCD(Curr, FMTBCD(BCD^), Precision, Decimals);
  3909. end;
  3910.  
  3911. function TBDEDataSet.GetStateFieldValue(State: TDataSetState; Field: TField): Variant;
  3912. begin
  3913.   CheckCachedUpdateMode;
  3914.   Result := inherited GetStateFieldValue(State, Field);
  3915. end;
  3916.  
  3917. procedure TBDEDataSet.SetStateFieldValue(State: TDataSetState; Field: TField; Value: Variant);
  3918. begin
  3919.   CheckCachedUpdateMode;
  3920.   inherited SetStateFieldValue(State, Field, Value);
  3921. end;
  3922.  
  3923. procedure TBDEDataSet.Translate(Src, Dest: PChar; ToOem: Boolean);
  3924. var
  3925.   Len: Integer;
  3926. begin
  3927.   Len := StrLen(Src);
  3928.   if ToOem then
  3929.     AnsiToNativeBuf(Locale, Src, Dest, Len) else
  3930.     NativeToAnsiBuf(Locale, Src, Dest, Len);
  3931.   if Len > 0 then Dest[Len] := #0;
  3932. end;
  3933.  
  3934. { Navigation / Editing }
  3935.  
  3936. procedure TBDEDataSet.InternalFirst;
  3937. begin
  3938.   Check(DbiSetToBegin(FHandle));
  3939. end;
  3940.  
  3941. procedure TBDEDataSet.InternalLast;
  3942. begin
  3943.   Check(DbiSetToEnd(FHandle));
  3944. end;
  3945.  
  3946. procedure TBDEDataSet.InternalEdit;
  3947. begin
  3948.   Check(DbiGetRecord(FHandle, dbiWriteLock, ActiveBuffer, nil));
  3949.   ClearBlobCache(ActiveBuffer);
  3950. end;
  3951.  
  3952. procedure TBDEDataSet.InternalPost;
  3953. begin
  3954.   if State = dsEdit then
  3955.     Check(DbiModifyRecord(FHandle, ActiveBuffer, True)) else
  3956.     Check(DbiInsertRecord(FHandle, dbiNoLock, ActiveBuffer));
  3957. end;
  3958.  
  3959. procedure TBDEDataSet.InternalDelete;
  3960. var
  3961.   Result: DBIResult;
  3962. begin
  3963.   Result := DbiDeleteRecord(FHandle, nil);
  3964.   if (Result <> DBIERR_NONE) and (Hi(Result) = ERRCAT_NOTFOUND) then
  3965.     Check(Result);
  3966. end;
  3967.  
  3968. function TBDEDataSet.GetCanModify: Boolean;
  3969. begin
  3970.   Result := FCanModify or ForceUpdateCallback;
  3971. end;
  3972.  
  3973. procedure TBDEDataSet.InternalRefresh;
  3974. begin
  3975.   Check(DbiForceReread(FHandle));
  3976. end;
  3977.  
  3978. procedure TBDEDataSet.Post;
  3979. begin
  3980.   inherited Post;
  3981.   if State = dsSetKey then
  3982.     PostKeyBuffer(True);
  3983. end;
  3984.  
  3985. procedure TBDEDataSet.Cancel;
  3986. begin
  3987.   inherited Cancel;
  3988.   if State = dsSetKey then
  3989.     PostKeyBuffer(False);
  3990. end;
  3991.  
  3992. procedure TBDEDataSet.InternalCancel;
  3993. begin
  3994.   DbiRelRecordLock(FHandle, False);
  3995. end;
  3996.  
  3997. procedure TBDEDataSet.InternalAddRecord(Buffer: Pointer; Append: Boolean);
  3998. begin
  3999.   if Append then
  4000.     Check(DbiAppendRecord(FHandle, Buffer)) else
  4001.     Check(DbiInsertRecord(FHandle, dbiNoLock, Buffer));
  4002. end;
  4003.  
  4004. procedure TBDEDataSet.InternalGotoBookmark(Bookmark: TBookmark);
  4005. begin
  4006.   Check(DbiSetToBookmark(FHandle, Bookmark));
  4007. end;
  4008.  
  4009. procedure TBDEDataSet.InternalSetToRecord(Buffer: PChar);
  4010. begin
  4011.   InternalGotoBookmark(Buffer + FBookmarkOfs);
  4012. end;
  4013.  
  4014. function TBDEDataSet.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag;
  4015. begin
  4016.   Result := PRecInfo(Buffer + FRecInfoOfs).BookmarkFlag;
  4017. end;
  4018.  
  4019. procedure TBDEDataSet.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag);
  4020. begin
  4021.   PRecInfo(Buffer + FRecInfoOfs).BookmarkFlag := Value;
  4022. end;
  4023.  
  4024. procedure TBDEDataSet.GetBookmarkData(Buffer: PChar; Data: Pointer);
  4025. begin
  4026.   Move(Buffer[FBookmarkOfs], Data^, BookmarkSize);
  4027. end;
  4028.  
  4029. procedure TBDEDataset.SetBookmarkData(Buffer: PChar; Data: Pointer);
  4030. begin
  4031.   Move(Data^, Buffer[FBookmarkOfs], BookmarkSize);
  4032. end;
  4033.  
  4034. function TBDEDataSet.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer;
  4035. const
  4036.   RetCodes: array[Boolean, Boolean] of ShortInt = ((2,CMPLess),(CMPGtr,CMPEql));
  4037. begin
  4038.   { Check for uninitialized bookmarks }
  4039.   Result := RetCodes[Bookmark1 = nil, Bookmark2 = nil];
  4040.   if Result = 2 then
  4041.   begin
  4042.     Check(DbiCompareBookmarks(Handle, Bookmark1, Bookmark2, Result));
  4043.     if Result = CMPKeyEql then Result := CMPEql;
  4044.   end;
  4045. end;
  4046.  
  4047. function TBDEDataSet.BookmarkValid(Bookmark: TBookmark): Boolean;
  4048. begin
  4049.   Result := DbiSetToBookmark(FHandle, Bookmark) = DBIERR_NONE;
  4050.   if Result then CursorPosChanged;
  4051. end;
  4052.  
  4053. { Index / Ranges }
  4054.  
  4055. procedure TBDEDataSet.GetIndexInfo;
  4056. var
  4057.   IndexDesc: IDXDesc;
  4058. begin
  4059.   if DbiGetIndexDesc(FHandle, 0, IndexDesc) = 0 then
  4060.   begin
  4061.     FExpIndex := IndexDesc.bExpIdx;
  4062.     FCaseInsIndex := IndexDesc.bCaseInsensitive;
  4063.     if not ExpIndex then
  4064.     begin
  4065.       FIndexFieldCount := IndexDesc.iFldsInKey;
  4066.       FIndexFieldMap := IndexDesc.aiKeyFld;
  4067.     end;
  4068.     FKeySize := IndexDesc.iKeyLen;
  4069.   end;
  4070. end;
  4071.  
  4072. procedure TBDEDataSet.SwitchToIndex(const IndexName, TagName: string);
  4073. var
  4074.   Status: DBIResult;
  4075. begin
  4076.   ResetCursorRange;
  4077.   UpdateCursorPos;
  4078.   Status := DbiSwitchToIndex(FHandle, PChar(IndexName),
  4079.     PChar(TagName), 0, True);
  4080.   if Status = DBIERR_NOCURRREC then
  4081.     Status := DbiSwitchToIndex(FHandle, PChar(IndexName),
  4082.     PChar(TagName), 0, False);
  4083.   Check(Status);
  4084.   FKeySize := 0;
  4085.   FExpIndex := False;
  4086.   FCaseInsIndex := False;
  4087.   FIndexFieldCount := 0;
  4088.   SetBufListSize(0);
  4089.   InitBufferPointers(True);
  4090.   try
  4091.     SetBufListSize(BufferCount + 1);
  4092.   except
  4093.     SetState(dsInactive);
  4094.     CloseCursor;
  4095.     raise;
  4096.   end;
  4097.   GetIndexInfo;
  4098. end;
  4099.  
  4100. function TBDEDataSet.GetIndexField(Index: Integer): TField;
  4101. var
  4102.   FieldNo: Integer;
  4103. begin
  4104.   if (Index < 0) or (Index >= FIndexFieldCount) then
  4105.     DatabaseError(SFieldIndexError);
  4106.   FieldNo := FIndexFieldMap[Index];
  4107.   Result := FieldByNumber(FieldNo);
  4108.   if Result = nil then
  4109.     DatabaseErrorFmt(SIndexFieldMissing, [FieldDefs[FieldNo - 1].Name]);
  4110. end;
  4111.  
  4112. procedure TBDEDataSet.SetIndexField(Index: Integer; Value: TField);
  4113. begin
  4114.   GetIndexField(Index).Assign(Value);
  4115. end;
  4116.  
  4117. function TBDEDataSet.GetIndexFieldCount: Integer;
  4118. begin
  4119.   Result := FIndexFieldCount;
  4120. end;
  4121.  
  4122. procedure TBDEDataSet.AllocKeyBuffers;
  4123. var
  4124.   KeyIndex: TKeyIndex;
  4125. begin
  4126.   try
  4127.     for KeyIndex := Low(TKeyIndex) to High(TKeyIndex) do
  4128.       FKeyBuffers[KeyIndex] := InitKeyBuffer(
  4129.         AllocMem(SizeOf(TKeyBuffer) + FRecordSize));
  4130.   except
  4131.     FreeKeyBuffers;
  4132.     raise;
  4133.   end;
  4134. end;
  4135.  
  4136. procedure TBDEDataSet.FreeKeyBuffers;
  4137. var
  4138.   KeyIndex: TKeyIndex;
  4139. begin
  4140.   for KeyIndex := Low(TKeyIndex) to High(TKeyIndex) do
  4141.     DisposeMem(FKeyBuffers[KeyIndex], SizeOf(TKeyBuffer) + FRecordSize);
  4142. end;
  4143.  
  4144. function TBDEDataSet.InitKeyBuffer(Buffer: PKeyBuffer): PKeyBuffer;
  4145. begin
  4146.   FillChar(Buffer^, SizeOf(TKeyBuffer) + FRecordSize, 0);
  4147.   DbiInitRecord(FHandle, PChar(Buffer) + SizeOf(TKeyBuffer));
  4148.   Result := Buffer;
  4149. end;
  4150.  
  4151. procedure TBDEDataSet.CheckSetKeyMode;
  4152. begin
  4153.   if State <> dsSetKey then DatabaseError(SNotEditing);
  4154. end;
  4155.  
  4156. function TBDEDataSet.SetCursorRange: Boolean;
  4157. var
  4158.   RangeStart, RangeEnd: PKeyBuffer;
  4159.   StartKey, EndKey: PChar;
  4160.   IndexBuffer: PChar;
  4161.   UseStartKey, UseEndKey, UseKey: Boolean;
  4162. begin
  4163.   Result := False;
  4164.   if not (
  4165.     BuffersEqual(FKeyBuffers[kiRangeStart], FKeyBuffers[kiCurRangeStart],
  4166.     SizeOf(TKeyBuffer) + FRecordSize) and
  4167.     BuffersEqual(FKeyBuffers[kiRangeEnd], FKeyBuffers[kiCurRangeEnd],
  4168.     SizeOf(TKeyBuffer) + FRecordSize)) then
  4169.   begin
  4170.     IndexBuffer := AllocMem(KeySize * 2);
  4171.     try
  4172.       UseStartKey := True;
  4173.       UseEndKey := True;
  4174.       RangeStart := FKeyBuffers[kiRangeStart];
  4175.       if RangeStart.Modified then
  4176.       begin
  4177.         StartKey := PChar(RangeStart) + SizeOf(TKeyBuffer);
  4178.         UseStartKey := DbiExtractKey(Handle, StartKey, IndexBuffer) = 0;
  4179.       end
  4180.       else StartKey := nil;
  4181.       RangeEnd := FKeyBuffers[kiRangeEnd];
  4182.       if RangeEnd.Modified then
  4183.       begin
  4184.         EndKey := PChar(RangeEnd) + SizeOf(TKeyBuffer);
  4185.         UseEndKey := DbiExtractKey(Handle, EndKey, IndexBuffer + KeySize) = 0;
  4186.       end
  4187.       else EndKey := nil;
  4188.       UseKey := UseStartKey and UseEndKey;
  4189.       if UseKey then
  4190.       begin
  4191.         if StartKey <> nil then StartKey := IndexBuffer;
  4192.         if EndKey <> nil then EndKey := IndexBuffer + KeySize;
  4193.       end;
  4194.       Check(DbiSetRange(FHandle, UseKey,
  4195.         RangeStart.FieldCount, 0, StartKey, not RangeStart.Exclusive,
  4196.         RangeEnd.FieldCount, 0, EndKey, not RangeEnd.Exclusive));
  4197.       Move(FKeyBuffers[kiRangeStart]^, FKeyBuffers[kiCurRangeStart]^,
  4198.         SizeOf(TKeyBuffer) + FRecordSize);
  4199.       Move(FKeyBuffers[kiRangeEnd]^, FKeyBuffers[kiCurRangeEnd]^,
  4200.         SizeOf(TKeyBuffer) + FRecordSize);
  4201.       DestroyLookupCursor;
  4202.       Result := True;
  4203.     finally
  4204.       FreeMem(IndexBuffer, KeySize * 2);
  4205.     end;
  4206.   end;
  4207. end;
  4208.  
  4209. function TBDEDataSet.ResetCursorRange: Boolean;
  4210. begin
  4211.   Result := False;
  4212.   if FKeyBuffers[kiCurRangeStart].Modified or
  4213.     FKeyBuffers[kiCurRangeEnd].Modified then
  4214.   begin
  4215.     Check(DbiResetRange(FHandle));
  4216.     InitKeyBuffer(FKeyBuffers[kiCurRangeStart]);
  4217.     InitKeyBuffer(FKeyBuffers[kiCurRangeEnd]);
  4218.     DestroyLookupCursor;
  4219.     Result := True;
  4220.   end;
  4221. end;
  4222.  
  4223. procedure TBDEDataSet.SetLinkRanges(MasterFields: TList);
  4224. var
  4225.   I: Integer;
  4226.   SaveState: TDataSetState;
  4227. begin
  4228.   SaveState := SetTempState(dsSetKey);
  4229.   try
  4230.     FKeyBuffer := InitKeyBuffer(FKeyBuffers[kiRangeStart]);
  4231.     FKeyBuffer^.Modified := True;
  4232.     for I := 0 to MasterFields.Count - 1 do
  4233.       GetIndexField(I).Assign(TField(MasterFields[I]));
  4234.     FKeyBuffer^.FieldCount := MasterFields.Count;
  4235.   finally
  4236.     RestoreState(SaveState);
  4237.   end;
  4238.   Move(FKeyBuffers[kiRangeStart]^, FKeyBuffers[kiRangeEnd]^,
  4239.     SizeOf(TKeyBuffer) + FRecordSize);
  4240. end;
  4241.  
  4242. function TBDEDataSet.GetKeyBuffer(KeyIndex: TKeyIndex): PKeyBuffer;
  4243. begin
  4244.   Result := FKeyBuffers[KeyIndex];
  4245. end;
  4246.  
  4247. procedure TBDEDataSet.SetKeyBuffer(KeyIndex: TKeyIndex; Clear: Boolean);
  4248. begin
  4249.   CheckBrowseMode;
  4250.   FKeyBuffer := FKeyBuffers[KeyIndex];
  4251.   Move(FKeyBuffer^, FKeyBuffers[kiSave]^, SizeOf(TKeyBuffer) + FRecordSize);
  4252.   if Clear then InitKeyBuffer(FKeyBuffer);
  4253.   SetState(dsSetKey);
  4254.   SetModified(FKeyBuffer.Modified);
  4255.   DataEvent(deDataSetChange, 0);
  4256. end;
  4257.  
  4258. procedure TBDEDataSet.PostKeyBuffer(Commit: Boolean);
  4259. begin
  4260.   DataEvent(deCheckBrowseMode, 0);
  4261.   if Commit then
  4262.     FKeyBuffer.Modified := Modified else
  4263.     Move(FKeyBuffers[kiSave]^, FKeyBuffer^, SizeOf(TKeyBuffer) + FRecordSize);
  4264.   SetState(dsBrowse);
  4265.   DataEvent(deDataSetChange, 0);
  4266. end;
  4267.  
  4268. function TBDEDataSet.GetKeyExclusive: Boolean;
  4269. begin
  4270.   CheckSetKeyMode;
  4271.   Result := FKeyBuffer.Exclusive;
  4272. end;
  4273.  
  4274. procedure TBDEDataSet.SetKeyExclusive(Value: Boolean);
  4275. begin
  4276.   CheckSetKeyMode;
  4277.   FKeyBuffer.Exclusive := Value;
  4278. end;
  4279.  
  4280. function TBDEDataSet.GetKeyFieldCount: Integer;
  4281. begin
  4282.   CheckSetKeyMode;
  4283.   Result := FKeyBuffer.FieldCount;
  4284. end;
  4285.  
  4286. procedure TBDEDataSet.SetKeyFieldCount(Value: Integer);
  4287. begin
  4288.   CheckSetKeyMode;
  4289.   FKeyBuffer.FieldCount := Value;
  4290. end;
  4291.  
  4292. procedure TBDEDataSet.SetKeyFields(KeyIndex: TKeyIndex;
  4293.   const Values: array of const);
  4294. var
  4295.   I: Integer;
  4296.   SaveState: TDataSetState;
  4297. begin
  4298.   if ExpIndex then DatabaseError(SCompositeIndexError);
  4299.   if FIndexFieldCount = 0 then DatabaseError(SNoFieldIndexes);
  4300.   SaveState := SetTempState(dsSetKey);
  4301.   try
  4302.     FKeyBuffer := InitKeyBuffer(FKeyBuffers[KeyIndex]);
  4303.     for I := 0 to High(Values) do GetIndexField(I).AssignValue(Values[I]);
  4304.     FKeyBuffer^.FieldCount := High(Values) + 1;
  4305.     FKeyBuffer^.Modified := Modified;
  4306.   finally
  4307.     RestoreState(SaveState);
  4308.   end;
  4309. end;
  4310.  
  4311. function TBDEDataSet.GetIsIndexField(Field: TField): Boolean;
  4312. var
  4313.   I: Integer;
  4314. begin
  4315.   if (State = dsSetKey) and (FIndexFieldCount = 0) and FExpIndex then
  4316.     Result := True else
  4317.   begin
  4318.     Result := False;
  4319.     with Field do
  4320.       if FieldNo > 0 then
  4321.         for I := 0 to FIndexFieldCount - 1 do
  4322.          if FIndexFieldMap[I] = FieldNo then
  4323.           begin
  4324.             Result := True;
  4325.             Exit;
  4326.           end;
  4327.   end;
  4328. end;
  4329.  
  4330. function TBDEDataSet.MapsToIndex(Fields: TList;
  4331.   CaseInsensitive: Boolean): Boolean;
  4332. var
  4333.   I: Integer;
  4334. begin
  4335.   Result := False;
  4336.   if CaseInsensitive and not FCaseInsIndex then Exit;
  4337.   if Fields.Count > FIndexFieldCount then Exit;
  4338.   for I := 0 to Fields.Count - 1 do
  4339.     if TField(Fields[I]).FieldNo <> FIndexFieldMap[I] then Exit;
  4340.   Result := True;
  4341. end;
  4342.  
  4343. { Filters }
  4344.  
  4345. procedure TBDEDataSet.ActivateFilters;
  4346. begin
  4347.   if FExprFilter <> nil then DbiActivateFilter(FHandle, FExprFilter);
  4348.   if FFuncFilter <> nil then DbiActivateFilter(FHandle, FFuncFilter);
  4349. end;
  4350.  
  4351. procedure TBDEDataSet.DeactivateFilters;
  4352. begin
  4353.   if FFuncFilter <> nil then DbiDeactivateFilter(FHandle, FFuncFilter);
  4354.   if FExprFilter <> nil then DbiDeactivateFilter(FHandle, FExprFilter);
  4355. end;
  4356.  
  4357. function TBDEDataSet.CreateExprFilter(const Expr: string;
  4358.   Options: TFilterOptions; Priority: Integer): HDBIFilter;
  4359. var
  4360.   Parser: TExprParser;
  4361. begin
  4362.   Parser := TExprParser.Create(Self, Expr, Options);
  4363.   try
  4364.     Check(DbiAddFilter(FHandle, 0, Priority, False, Parser.FilterData,
  4365.       nil, Result));
  4366.   finally
  4367.     Parser.Free;
  4368.   end;
  4369. end;
  4370.  
  4371. function TBDEDataSet.CreateFuncFilter(FilterFunc: Pointer;
  4372.   Priority: Integer): HDBIFilter;
  4373. begin
  4374.   Check(DbiAddFilter(FHandle, Integer(Self), Priority, False, nil,
  4375.     PFGENFilter(FilterFunc), Result));
  4376. end;
  4377.  
  4378. {$WARNINGS OFF}
  4379. function TBDEDataSet.CreateLookupFilter(Fields: TList; const Values: Variant;
  4380.   Options: TLocateOptions; Priority: Integer): HDBIFilter;
  4381. var
  4382.   I: Integer;
  4383.   Filter: TFilterExpr;
  4384.   Expr, Node: PExprNode;
  4385.   FilterOptions: TFilterOptions;
  4386. begin
  4387.   if loCaseInsensitive in Options then
  4388.     FilterOptions := [foNoPartialCompare, foCaseInsensitive] else
  4389.     FilterOptions := [foNoPartialCompare];
  4390.   Filter := TFilterExpr.Create(Self, FilterOptions);
  4391.   try
  4392.     if Fields.Count = 1 then
  4393.     begin
  4394.       Node := Filter.NewCompareNode(TField(Fields[0]), canEQ, Values);
  4395.       Expr := Node;
  4396.     end else
  4397.       for I := 0 to Fields.Count - 1 do
  4398.       begin
  4399.         Node := Filter.NewCompareNode(TField(Fields[I]), canEQ, Values[I]);
  4400.         if I = 0 then
  4401.           Expr := Node else
  4402.           Expr := Filter.NewNode(enOperator, canAND, Unassigned, Expr, Node);
  4403.       end;
  4404.     if loPartialKey in Options then Node^.FPartial := True;
  4405.     Check(DbiAddFilter(FHandle, 0, Priority, False,
  4406.       Filter.GetFilterData(Expr), nil, Result));
  4407.   finally
  4408.     Filter.Free;
  4409.   end;
  4410. end;
  4411. {$WARNINGS ON}
  4412.  
  4413. procedure TBDEDataSet.SetFilterHandle(var Filter: HDBIFilter;
  4414.   Value: HDBIFilter);
  4415. begin
  4416.   if Filtered then
  4417.   begin
  4418.     CursorPosChanged;
  4419.     DestroyLookupCursor;
  4420.     DbiSetToBegin(FHandle);
  4421.     if Filter <> nil then DbiDropFilter(FHandle, Filter);
  4422.     Filter := Value;
  4423.     if Filter <> nil then DbiActivateFilter(FHandle, Filter);
  4424.   end else
  4425.     Filter := Value;
  4426. end;
  4427.  
  4428. procedure TBDEDataSet.SetFilterData(const Text: string; Options: TFilterOptions);
  4429. var
  4430.   HFilter: HDBIFilter;
  4431. begin
  4432.   if Active then
  4433.   begin
  4434.     CheckBrowseMode;
  4435.     if (Filter <> Text) or (FilterOptions <> Options) then
  4436.     begin
  4437.       if Text <> '' then
  4438.         HFilter := CreateExprFilter(Text, Options, 0) else
  4439.         HFilter := nil;
  4440.       SetFilterHandle(FExprFilter, HFilter);
  4441.     end;
  4442.   end;
  4443.   inherited SetFilterText(Text);
  4444.   inherited SetFilterOptions(Options);
  4445.   if Active and Filtered then First;
  4446. end;
  4447.  
  4448. procedure TBDEDataSet.SetFilterText(const Value: string);
  4449. begin
  4450.   SetFilterData(Value, FilterOptions);
  4451. end;
  4452.  
  4453. procedure TBDEDataSet.SetFiltered(Value: Boolean);
  4454. begin
  4455.   if Active then
  4456.   begin
  4457.     CheckBrowseMode;
  4458.     if Filtered <> Value then
  4459.     begin
  4460.       DestroyLookupCursor;
  4461.       DbiSetToBegin(FHandle);
  4462.       if Value then ActivateFilters else DeactivateFilters;
  4463.       inherited SetFiltered(Value);
  4464.     end;
  4465.     First;
  4466.   end else
  4467.     inherited SetFiltered(Value);
  4468. end;
  4469.  
  4470. procedure TBDEDataSet.SetFilterOptions(Value: TFilterOptions);
  4471. begin
  4472.   SetFilterData(Filter, Value);
  4473. end;
  4474.  
  4475. procedure TBDEDataSet.SetOnFilterRecord(const Value: TFilterRecordEvent);
  4476. var
  4477.   Filter: HDBIFilter;
  4478. begin
  4479.   if Active then
  4480.   begin
  4481.     CheckBrowseMode;
  4482.     if Assigned(OnFilterRecord) <> Assigned(Value) then
  4483.     begin
  4484.       if Assigned(Value) then
  4485.         Filter := CreateFuncFilter(@TBDEDataSet.RecordFilter, 1) else
  4486.         Filter := nil;
  4487.       SetFilterHandle(FFuncFilter, Filter);
  4488.     end;
  4489.     inherited SetOnFilterRecord(Value);
  4490.     if Filtered then First;
  4491.   end else
  4492.     inherited SetOnFilterRecord(Value);
  4493. end;
  4494.  
  4495. function TBDEDataSet.FindRecord(Restart, GoForward: Boolean): Boolean;
  4496. var
  4497.   Status: DBIResult;
  4498. begin
  4499.   CheckBrowseMode;
  4500.   DoBeforeScroll;
  4501.   SetFound(False);
  4502.   UpdateCursorPos;
  4503.   CursorPosChanged;
  4504.   if not Filtered then ActivateFilters;
  4505.   try
  4506.     if GoForward then
  4507.     begin
  4508.       if Restart then Check(DbiSetToBegin(FHandle));
  4509.       Status := DbiGetNextRecord(FHandle, dbiNoLock, nil, nil);
  4510.     end else
  4511.     begin
  4512.       if Restart then Check(DbiSetToEnd(FHandle));
  4513.       Status := DbiGetPriorRecord(FHandle, dbiNoLock, nil, nil);
  4514.     end;
  4515.   finally
  4516.     if not Filtered then DeactivateFilters;
  4517.   end;
  4518.   if Status = DBIERR_NONE then
  4519.   begin
  4520.     Resync([rmExact, rmCenter]);
  4521.     SetFound(True);
  4522.   end;
  4523.   Result := Found;
  4524.   if Result then DoAfterScroll;
  4525. end;
  4526.  
  4527. function TBDEDataSet.RecordFilter(RecBuf: Pointer; RecNo: Integer): Smallint;
  4528. var
  4529.   Accept: Boolean;
  4530.   SaveState: TDataSetState;
  4531. begin
  4532.   SaveState := SetTempState(dsFilter);
  4533.   FFilterBuffer := RecBuf;
  4534.   try
  4535.     Accept := True;
  4536.     OnFilterRecord(Self, Accept);
  4537.   except
  4538.     Application.HandleException(Self);
  4539.   end;
  4540.   RestoreState(SaveState);
  4541.   Result := Ord(Accept);
  4542. end;
  4543.  
  4544. function TBDEDataSet.LocateRecord(const KeyFields: string;
  4545.   const KeyValues: Variant; Options: TLocateOptions;
  4546.   SyncCursor: Boolean): Boolean;
  4547. var
  4548.   I, FieldCount, PartialLength: Integer;
  4549.   Buffer: PChar;
  4550.   Fields: TList;
  4551.   LookupCursor: HDBICur;
  4552.   Filter: HDBIFilter;
  4553.   Status: DBIResult;
  4554.   CaseInsensitive: Boolean;
  4555. begin
  4556.   CheckBrowseMode;
  4557.   CursorPosChanged;
  4558.   Buffer := TempBuffer;
  4559.   Fields := TList.Create;
  4560.   try
  4561.     GetFieldList(Fields, KeyFields);
  4562.     CaseInsensitive := loCaseInsensitive in Options;
  4563.     if CachedUpdates then
  4564.       LookupCursor := nil
  4565.     else
  4566.       if MapsToIndex(Fields, CaseInsensitive) then
  4567.         LookupCursor := FHandle else
  4568.         LookupCursor := GetLookupCursor(KeyFields, CaseInsensitive);
  4569.     if (LookupCursor <> nil) then
  4570.     begin
  4571.       SetTempState(dsFilter);
  4572.       FFilterBuffer := Buffer;
  4573.       try
  4574.         DbiInitRecord(LookupCursor, Buffer);
  4575.         FieldCount := Fields.Count;
  4576.         if FieldCount = 1 then
  4577.           TField(Fields.First).Value := KeyValues
  4578.         else
  4579.           for I := 0 to FieldCount - 1 do
  4580.             TField(Fields[I]).Value := KeyValues[I];
  4581.         PartialLength := 0;
  4582.         if (loPartialKey in Options) and
  4583.           (TField(Fields.Last).DataType = ftString) then
  4584.         begin
  4585.           Dec(FieldCount);
  4586.           PartialLength := Length(TField(Fields.Last).AsString);
  4587.         end;
  4588.         Status := DbiGetRecordForKey(LookupCursor, False, FieldCount,
  4589.           PartialLength, Buffer, Buffer);
  4590.       finally
  4591.         RestoreState(dsBrowse);
  4592.       end;
  4593.       if (Status = DBIERR_NONE) and SyncCursor and
  4594.         (LookupCursor <> FHandle) then
  4595.         Status := DbiSetToCursor(FHandle, LookupCursor);
  4596.     end else
  4597.     begin
  4598.       Check(DbiSetToBegin(FHandle));
  4599.       Filter := CreateLookupFilter(Fields, KeyValues, Options, 2);
  4600.       DbiActivateFilter(FHandle, Filter);
  4601.       Status := DbiGetNextRecord(FHandle, dbiNoLock, Buffer, nil);
  4602.       DbiDropFilter(FHandle, Filter);
  4603.     end;
  4604.   finally
  4605.     Fields.Free;
  4606.   end;
  4607.   Result := Status = DBIERR_NONE;
  4608. end;
  4609.  
  4610. function TBDEDataSet.Lookup(const KeyFields: string; const KeyValues: Variant;
  4611.   const ResultFields: string): Variant;
  4612. begin
  4613.   Result := Null;
  4614.   if LocateRecord(KeyFields, KeyValues, [], False) then
  4615.   begin
  4616.     SetTempState(dsCalcFields);
  4617.     try
  4618.       CalculateFields(TempBuffer);
  4619.       Result := FieldValues[ResultFields];
  4620.     finally
  4621.       RestoreState(dsBrowse);
  4622.     end;
  4623.   end;
  4624. end;
  4625.  
  4626. function TBDEDataSet.Locate(const KeyFields: string;
  4627.   const KeyValues: Variant; Options: TLocateOptions): Boolean;
  4628. begin
  4629.   DoBeforeScroll;
  4630.   Result := LocateRecord(KeyFields, KeyValues, Options, True);
  4631.   if Result then
  4632.   begin
  4633.     Resync([rmExact, rmCenter]);
  4634.     DoAfterScroll;
  4635.   end;
  4636. end;
  4637.  
  4638. function TBDEDataSet.GetLookupCursor(const KeyFields: string;
  4639.   CaseInsensitive: Boolean): HDBICur;
  4640. begin
  4641.   Result := nil;
  4642. end;
  4643.  
  4644. procedure TBDEDataSet.DestroyLookupCursor;
  4645. begin
  4646. end;
  4647.  
  4648. function TBDEDataSet.HasConstraints: Boolean;
  4649. var
  4650.   I: Integer;
  4651. begin
  4652.   Result := True;
  4653.   if Constraints.Count > 0 then Exit;
  4654.   for I := 0 to FieldCount - 1 do
  4655.     if Fields[I].HasConstraints then Exit;
  4656.   Result := False;
  4657. end;
  4658.  
  4659. procedure TBDEDataSet.DisableConstraints;
  4660. begin
  4661.   if FConstDisableCount = 0 then
  4662.     Check(DbiSetProp(hDbiObj(Handle), curCONSTSTATE, Longint(False)));
  4663.   Inc(FConstDisableCount);
  4664. end;
  4665.  
  4666. procedure TBDEDataSet.EnableConstraints;
  4667. begin
  4668.   if FConstDisableCount <> 0 then
  4669.   begin
  4670.     Dec(FConstDisableCount);
  4671.     if FConstDisableCount = 0 then
  4672.       Check(DbiSetProp(hDbiObj(Handle), curCONSTSTATE, Longint(True)));
  4673.   end;
  4674. end;
  4675.  
  4676. function TBDEDataSet.ConstraintCallBack(Req: DsInfoReq;
  4677.   var ADataSources: DataSources): DBIResult;
  4678.  
  4679.   function GetPChar(const S: string): PChar;
  4680.   begin
  4681.     if S <> '' then Result := PChar(Pointer(S)) else Result := '';
  4682.   end;
  4683.  
  4684.   function GetFieldSource: Boolean;
  4685.   var
  4686.     Current: PChar;
  4687.     Field: TField;
  4688.     Values: array[0..4] of string;
  4689.     I: Integer;
  4690.  
  4691.     procedure Split(const S: string);
  4692.     begin
  4693.       Current := PChar(Pointer(S));
  4694.     end;
  4695.  
  4696.     function NextItem: string;
  4697.     var
  4698.       C: PChar;
  4699.       I: PChar;
  4700.       Terminator: Char;
  4701.       Ident: array[0..1023] of Char;
  4702.     begin
  4703.       Result := '';
  4704.       C := Current;
  4705.       I := Ident;
  4706.       while C^ in ['.',' ',#0] do
  4707.         if C^ = #0 then Exit else Inc(C);
  4708.       Terminator := '.';
  4709.       if C^ = '"' then
  4710.       begin
  4711.         Terminator := '"';
  4712.         Inc(C);
  4713.       end;
  4714.       while not (C^ in [Terminator, #0]) do
  4715.       begin
  4716.         if C^ in LeadBytes then
  4717.         begin
  4718.           I^ := C^;
  4719.           Inc(C);
  4720.           Inc(I);
  4721.         end
  4722.         else if C^ = '\' then
  4723.         begin
  4724.           Inc(C);
  4725.           if C^ in LeadBytes then
  4726.           begin
  4727.             I^ := C^;
  4728.             Inc(C);
  4729.             Inc(I);
  4730.           end;
  4731.           if C^ = #0 then Dec(C);
  4732.         end;
  4733.         I^ := C^;
  4734.         Inc(C);
  4735.         Inc(I);
  4736.       end;
  4737.       SetString(Result, Ident, I - Ident);
  4738.       if (Terminator = '"') and (C^ <> #0) then Inc(C);
  4739.       Current := C;
  4740.     end;
  4741.  
  4742.     function PopValue: PChar;
  4743.     begin
  4744.       if I >= 0 then
  4745.       begin
  4746.         Result := GetPChar(Values[I]);
  4747.         Dec(I);
  4748.       end else Result := '';
  4749.     end;
  4750.  
  4751.   begin
  4752.     Result := False;
  4753.     Field := FindField(ADataSources.szSourceFldName);
  4754.     if (Field = nil) or (Field.Origin = '') then Exit;
  4755.     Split(Field.Origin);
  4756.     I := -1;
  4757.     repeat
  4758.       Inc(I);
  4759.       Values[I] := NextItem;
  4760.     until (Values[I] = '') or (I = High(Values));
  4761.     if I = High(Values) then Exit;
  4762.     Dec(I);
  4763.     StrCopy(ADataSources.szOrigFldName, PopValue);
  4764.     StrCopy(ADataSources.szTblName, PopValue);
  4765.     StrCopy(ADataSources.szDbName, PopValue);
  4766.     Result := (ADataSources.szOrigFldName[0] <> #0) and
  4767.       (ADataSources.szTblName[0] <> #0);
  4768.   end;
  4769.  
  4770.   function GetFieldConstraint: Boolean;
  4771.   var
  4772.     Field: TField;
  4773.   begin
  4774.     Result := False;
  4775.     Field := FindField(ADataSources.szSourceFldName);
  4776.     if (Field <> nil) and ((Field.ImportedConstraint <> '') or (Field.CustomConstraint <> '')) then
  4777.     begin
  4778.       StrCopy(ADataSources.szSQLExprImport, GetPChar(Field.ImportedConstraint));
  4779.       StrCopy(ADataSources.szSQLExprCustom, GetPChar(Field.CustomConstraint));
  4780.       StrCopy(ADataSources.szErrStrCustom, GetPChar(Field.ConstraintErrorMessage));
  4781.       StrCopy(ADataSources.szErrStrImport, GetPChar(Field.ConstraintErrorMessage));
  4782.       Result := True;
  4783.     end;
  4784.   end;
  4785.  
  4786.   procedure GetTableConstraint;
  4787.   begin
  4788.     with ADataSources, Constraints[iNumElem - 1] do
  4789.     begin
  4790.       StrCopy(szSQLExprImport, GetPChar(ImportedConstraint));
  4791.       StrCopy(szSQLExprCustom, GetPChar(CustomConstraint));
  4792.       StrCopy(szErrStrCustom, GetPChar(ErrorMessage));
  4793.     end;
  4794.   end;
  4795.  
  4796.   function GetDefaultExpression: Boolean;
  4797.   var
  4798.     Field: TField;
  4799.   begin
  4800.     Result := False;
  4801.     Field := FindField(ADataSources.szSourceFldName);
  4802.     if (Field <> nil) and (Field.DefaultExpression <> '') then
  4803.     begin
  4804.       StrCopy(ADataSources.szSQLExprImport, GetPChar(Field.DefaultExpression));
  4805.       Result := True;
  4806.     end;
  4807.   end;
  4808.  
  4809. begin
  4810.   Result := DBIERR_NA;
  4811.   try
  4812.     case Req of
  4813.       dsFieldSource: if GetFieldSource then Result := DBIERR_NONE;
  4814.       dsFieldDomainExpr: if GetFieldConstraint then Result := DBIERR_NONE;
  4815.       dsFieldDefault: if GetDefaultExpression then Result := DBIERR_NONE;
  4816.       dsNumTblConstraint:
  4817.         begin
  4818.           ADataSources.iNumElem := Constraints.Count;
  4819.           Result := DBIERR_NONE;
  4820.         end;
  4821.       dsTblConstraint:
  4822.         begin
  4823.           GetTableConstraint;
  4824.           Result := DBIERR_NONE;
  4825.         end;
  4826.     end;
  4827.   except
  4828.   end;
  4829. end;
  4830.  
  4831. { Cached Updates }
  4832.  
  4833. procedure TBDEDataSet.AllocCachedUpdateBuffers(Allocate: Boolean);
  4834. begin
  4835.   if Allocate then
  4836.   begin
  4837.     FUpdateCBBuf := AllocMem(SizeOf(DELAYUPDCbDesc));
  4838.     FUpdateCBBuf.pNewRecBuf := StrAlloc(FRecBufSize);
  4839.     FUpdateCBBuf.pOldRecBuf := StrAlloc(FRecBufSize);
  4840.     FUpdateCBBuf.iRecBufSize := FRecordSize;
  4841.   end else
  4842.   begin
  4843.     if Assigned(FUpdateCBBuf) then
  4844.     begin
  4845.       StrDispose(FUpdateCBBuf.pNewRecBuf);
  4846.       StrDispose(FUpdateCBBuf.pOldRecBuf);
  4847.       DisposeMem(FUpdateCBBuf, SizeOf(DELAYUPDCbDesc));
  4848.     end;
  4849.   end;
  4850. end;
  4851.  
  4852. procedure TBDEDataSet.CheckCachedUpdateMode;
  4853. begin
  4854.   if not CachedUpdates then DatabaseError(SNoCachedUpdates);
  4855. end;
  4856.  
  4857. function TBDEDataSet.UpdateCallbackRequired: Boolean;
  4858. begin
  4859.   Result := FCachedUpdates and (Assigned(FOnUpdateError) or
  4860.     Assigned(FOnUpdateRecord) or Assigned(FUpdateObject));
  4861. end;
  4862.  
  4863. function TBDEDataSet.ForceUpdateCallback: Boolean;
  4864. begin
  4865.   Result := FCachedUpdates and (Assigned(FOnUpdateRecord) or
  4866.     Assigned(FUpdateObject));
  4867. end;
  4868.  
  4869. procedure TBDEDataSet.SetCachedUpdates(Value: Boolean);
  4870.  
  4871.   procedure ReAllocBuffers;
  4872.   begin
  4873.     FreeFieldBuffers;
  4874.     FreeKeyBuffers;
  4875.     SetBufListSize(0);
  4876.     try
  4877.       InitBufferPointers(True);
  4878.       SetBufListSize(BufferCount + 1);
  4879.       AllocKeyBuffers;
  4880.     except
  4881.       SetState(dsInactive);
  4882.       CloseCursor;
  4883.       raise;
  4884.     end;
  4885.   end;
  4886.  
  4887. begin
  4888.   if (State = dsInActive) or (csDesigning in ComponentState) then
  4889.     FCachedUpdates := Value
  4890.   else if FCachedUpdates <> Value then
  4891.   begin
  4892.     CheckBrowseMode;
  4893.     UpdateCursorPos;
  4894.     if HasConstraints then DbiEndConstraintLayer(FHandle);
  4895.     if FCachedUpdates then
  4896.       Check(DbiEndDelayedUpdates(FHandle)) else
  4897.       Check(DbiBeginDelayedUpdates(FHandle));
  4898.     if HasConstraints then
  4899.       Check(DbiBeginConstraintLayer(FConstraintsDB, FHandle,
  4900.         @TBDEDataSet.ConstraintCallBack, Integer(Pointer(Self))));
  4901.     FCachedUpdates := Value;
  4902.     ReAllocBuffers;
  4903.     AllocCachedUpdateBuffers(Value);
  4904.     SetupCallBack(UpdateCallBackRequired);
  4905.     Resync([]);
  4906.   end;
  4907. end;
  4908.  
  4909. procedure TBDEDataSet.SetupCallBack(Value: Boolean);
  4910. begin
  4911.   if Value then
  4912.   begin
  4913.     if (csDesigning in ComponentState) then Exit;
  4914.     if not Assigned(FUpdateCallback) then
  4915.       FUpdateCallback := TBDECallback.Create(Self, Self.Handle, cbDELAYEDUPD,
  4916.         FUpdateCBBuf, SizeOf(DELAYUPDCbDesc), CachedUpdateCallBack, True);
  4917.   end
  4918.   else
  4919.   begin
  4920.     if Assigned(FUpdateCallback) then
  4921.     begin
  4922.       FUpdateCallback.Free;
  4923.       FUpdateCallback := nil;
  4924.     end;
  4925.   end;
  4926. end;
  4927.  
  4928. function TBDEDataSet.ProcessUpdates(UpdCmd: DBIDelayedUpdCmd): DBIResult;
  4929. begin
  4930.   CheckCachedUpdateMode;
  4931.   UpdateCursorPos;
  4932.   Result := DbiApplyDelayedUpdates(Handle, UpdCmd);
  4933.   Resync([]);
  4934. end;
  4935.  
  4936. procedure TBDEDataSet.ApplyUpdates;
  4937. var
  4938.   Status: DBIResult;
  4939. begin
  4940.   if State <> dsBrowse then Post;
  4941.   Status := ProcessUpdates(dbiDelayedUpdPrepare);
  4942.   if Status <> DBIERR_NONE then
  4943.     if Status = DBIERR_UPDATEABORT then SysUtils.Abort
  4944.     else DbiError(Status);
  4945. end;
  4946.  
  4947. procedure TBDEDataSet.CommitUpdates;
  4948. begin
  4949.   Check(ProcessUpdates(dbiDelayedUpdCommit));
  4950. end;
  4951.  
  4952. procedure TBDEDataSet.CancelUpdates;
  4953. begin
  4954.   Cancel;
  4955.   ProcessUpdates(dbiDelayedUpdCancel);
  4956. end;
  4957.  
  4958. procedure TBDEDataSet.RevertRecord;
  4959. var
  4960.   Status: DBIResult;
  4961. begin
  4962.   if State in dsEditModes then Cancel;
  4963.   Status := ProcessUpdates(dbiDelayedUpdCancelCurrent);
  4964.   if not ((Status = DBIERR_NONE) or (Status = DBIERR_NOTSUPPORTED)) then
  4965.     Check(Status);
  4966. end;
  4967.  
  4968. function TBDEDataSet.UpdateStatus: TUpdateStatus;
  4969. var
  4970.   BufPtr: PChar;
  4971. begin
  4972.   CheckCachedUpdateMode;
  4973.   if State = dsCalcFields then
  4974.     BufPtr := CalcBuffer else
  4975.     BufPtr := ActiveBuffer;
  4976.   Result := PRecInfo(BufPtr + FRecInfoOfs).UpdateStatus;
  4977. end;
  4978.  
  4979. function TBDEDataSet.CachedUpdateCallBack(CBInfo: Pointer): CBRType;
  4980. const
  4981.   CBRetCode: array[TUpdateAction] of CBRType = (cbrAbort, cbrAbort,
  4982.     cbrSkip, cbrRetry, cbrPartialAssist);
  4983. var
  4984.   UpdateAction: TUpdateAction;
  4985.   UpdateKind: TUpdateKind;
  4986. begin
  4987.   Result := cbrUSEDEF;
  4988.   try
  4989.     FInUpdateCallBack := True;
  4990.     UpdateAction := uaFail;
  4991.     UpdateKind := TUpdateKind(ord(FUpdateCBBuf.eDelayUpdOpType)-1);
  4992.     try
  4993.       if Assigned(FOnUpdateRecord) then
  4994.         FOnUpdateRecord(Self, UpdateKind, UpdateAction)
  4995.       else
  4996.         if Assigned(FUpdateObject) then
  4997.         begin
  4998.           FUpdateObject.Apply(UpdateKind);
  4999.           UpdateAction := uaApplied;
  5000.         end
  5001.       else
  5002.         DbiError(FUpdateCBBuf.iErrCode);
  5003.     except
  5004.       on E: EDatabaseError do
  5005.       begin
  5006.         if Assigned(FOnUpdateError) then
  5007.           FOnUpdateError(Self, E, UpdateKind, UpdateAction)
  5008.         else
  5009.         begin
  5010.           Application.HandleException(Self);
  5011.           UpdateAction := uaAbort;
  5012.         end;
  5013.       end;
  5014.     end;
  5015.     Result := CBRetCode[UpdateAction];
  5016.     if UpdateAction = uaAbort then FUpdateCBBuf.iErrCode := DBIERR_UPDATEABORT;
  5017.   except
  5018.     Application.HandleException(Self);
  5019.   end;
  5020.   FInUpdateCallBack := False;
  5021. end;
  5022.  
  5023. function TBDEDataSet.GetUpdateRecordSet: TUpdateRecordTypes;
  5024. begin
  5025.   if Active then
  5026.   begin
  5027.     CheckCachedUpdateMode;
  5028.     Result := TUpdateRecordTypes(Byte(GetIntProp(FHandle, curDELAYUPDDISPLAYOPT)));
  5029.   end
  5030.   else
  5031.     Result := [];
  5032. end;
  5033.  
  5034. procedure TBDEDataSet.SetUpdateRecordSet(RecordTypes: TUpdateRecordTypes);
  5035. begin
  5036.   CheckCachedUpdateMode;
  5037.   CheckBrowseMode;
  5038.   UpdateCursorPos;
  5039.   Check(DbiSetProp(hDbiObj(Handle), curDELAYUPDDISPLAYOPT, Longint(Byte(RecordTypes))));
  5040.   Resync([]);
  5041. end;
  5042.  
  5043. procedure TBDEDataSet.SetUpdateObject(Value: TDataSetUpdateObject);
  5044. begin
  5045.   if Value <> FUpdateObject then
  5046.   begin
  5047.     if Assigned(FUpdateObject) and (FUpdateObject.DataSet = Self) then
  5048.       FUpdateObject.DataSet := nil;
  5049.     FUpdateObject := Value;
  5050.     if Assigned(FUpdateObject) then
  5051.     begin
  5052.       { If another dataset already references this updateobject, then
  5053.         remove the reference }
  5054.       if Assigned(FUpdateObject.DataSet) and
  5055.         (FUpdateObject.DataSet <> Self) then
  5056.         FUpdateObject.DataSet.UpdateObject := nil;
  5057.       FUpdateObject.DataSet := Self;
  5058.     end;
  5059.   end;
  5060. end;
  5061.  
  5062. procedure TBDEDataSet.SetOnUpdateError(UpdateEvent: TUpdateErrorEvent);
  5063. begin
  5064.   if Active then SetupCallback(UpdateCallBackRequired);
  5065.   FOnUpdateError := UpdateEvent;
  5066. end;
  5067.  
  5068. function TBDEDataSet.GetUpdatesPending: Boolean;
  5069. begin
  5070.   Result := GetIntProp(FHandle, curDELAYUPDNUMUPDATES) > 0;
  5071. end;
  5072.  
  5073. function TBDEDataSet.YieldCallBack(CBInfo: Pointer): CBRType;
  5074. var
  5075.   AbortQuery: Boolean;
  5076. begin
  5077.   AbortQuery := False;
  5078.   if Assigned(OnServerYield) and (FCBYieldStep <> cbYieldLast) then
  5079.     OnServerYield(Self, AbortQuery);
  5080.   if AbortQuery then
  5081.     Result := cbrABORT else
  5082.     Result := cbrUSEDEF;
  5083. end;
  5084.  
  5085. { TDBDataSet }
  5086.  
  5087. procedure TDBDataSet.OpenCursor(InfoQuery: Boolean);
  5088. begin
  5089.   SetDBFlag(dbfOpened, True);
  5090.   inherited OpenCursor(InfoQuery);
  5091.   SetUpdateMode(FUpdateMode);
  5092. end;
  5093.  
  5094. procedure TDBDataSet.CloseCursor;
  5095. begin
  5096.   inherited CloseCursor;
  5097.   SetDBFlag(dbfOpened, False);
  5098. end;
  5099.  
  5100. procedure TDBDataSet.CheckDBSessionName;
  5101. var
  5102.   S: TSession;
  5103.   Database: TDatabase;
  5104. begin
  5105.   if (SessionName <> '') and (DatabaseName <> '') then
  5106.   begin
  5107.     S := Sessions.FindSession(SessionName);
  5108.     if Assigned(S) and not Assigned(S.FindDatabase(DatabaseName)) then
  5109.     begin
  5110.       Database := DefaultSession.FindDatabase(DatabaseName);
  5111.       if Assigned(Database) then Database.CheckSessionName(True);
  5112.     end;
  5113.   end;
  5114. end;
  5115.  
  5116. function TDBDataSet.CheckOpen(Status: DBIResult): Boolean;
  5117. begin
  5118.   case Status of
  5119.     DBIERR_NONE:
  5120.       Result := True;
  5121.     DBIERR_NOTSUFFTABLERIGHTS:
  5122.       begin
  5123.         if not DBSession.GetPassword then DbiError(Status);
  5124.         Result := False;
  5125.       end;
  5126.   else
  5127.     DbiError(Status);
  5128.     Result := False;
  5129.   end;
  5130. end;
  5131.  
  5132. procedure TDBDataSet.Disconnect;
  5133. begin
  5134.   Close;
  5135. end;
  5136.  
  5137. procedure TDBDataSet.SetDBFlag(Flag: Integer; Value: Boolean);
  5138. begin
  5139.   if Value then
  5140.   begin
  5141.     if not (Flag in FDBFlags) then
  5142.     begin
  5143.       if FDBFlags = [] then
  5144.       begin
  5145.         CheckDBSessionName;
  5146.         FDatabase := Sessions.List[SessionName].OpenDatabase(FDatabaseName);
  5147.         FDatabase.FDataSets.Add(Self);
  5148.         SetLocale(FDatabase.Locale);
  5149.       end;
  5150.       Include(FDBFlags, Flag);
  5151.     end;
  5152.   end else
  5153.   begin
  5154.     if Flag in FDBFlags then
  5155.     begin
  5156.       Exclude(FDBFlags, Flag);
  5157.       if FDBFlags = [] then
  5158.       begin
  5159.         SetLocale(DBLocale);
  5160.         FDatabase.FDataSets.Remove(Self);
  5161.         FDatabase.Session.CloseDatabase(FDatabase);
  5162.         FDatabase := nil;
  5163.       end;
  5164.     end;
  5165.   end;
  5166. end;
  5167.  
  5168. function TDBDataSet.GetDBHandle: HDBIDB;
  5169. begin
  5170.   if FDatabase <> nil then
  5171.     Result := FDatabase.Handle else
  5172.     Result := nil;
  5173. end;
  5174.  
  5175. function TDBDataSet.GetDBLocale: TLocale;
  5176. begin
  5177.   if Database <> nil then
  5178.     Result := Database.Locale else
  5179.     Result := nil;
  5180. end;
  5181.  
  5182. function TDBDataSet.GetDBSession: TSession;
  5183. begin
  5184.   if (FDatabase <> nil) then
  5185.     Result := FDatabase.Session else
  5186.     Result := Sessions.FindSession(SessionName);
  5187.   if Result = nil then Result := DefaultSession;
  5188. end;
  5189.  
  5190. procedure TDBDataSet.SetDatabaseName(const Value: string);
  5191. begin
  5192.   if FDatabaseName <> Value then
  5193.   begin
  5194.     CheckInactive;
  5195.     if FDatabase <> nil then DatabaseError(SDatabaseOpen);
  5196.     FDatabaseName := Value;
  5197.     DataEvent(dePropertyChange, 0);
  5198.   end;
  5199. end;
  5200.  
  5201. procedure TDBDataSet.SetSessionName(const Value: string);
  5202. begin
  5203.   CheckInactive;
  5204.   FSessionName := Value;
  5205.   { !!! Add a better flag here to check if we are fully instansiated }
  5206.   if FieldDefs <> nil then
  5207.     DataEvent(dePropertyChange, 0);
  5208. end;
  5209.  
  5210. procedure TDBDataSet.SetUpdateMode(const Value: TUpdateMode);
  5211. begin
  5212.   if (FHandle <> nil) and Database.IsSQLBased and CanModify then
  5213.     Check(DbiSetProp(hDbiObj(FHandle), curUPDLOCKMODE, Longint(Value)));
  5214.   FUpdateMode := Value;
  5215. end;
  5216.  
  5217. function TDBDataSet.GetProvider: IProvider;
  5218. begin
  5219.   if not Assigned(FProvIntf) and Assigned(CreateProviderProc) then
  5220.     FProvIntf := CreateProviderProc(Self);
  5221.   Result := FProvIntf;
  5222. end;
  5223.  
  5224. function TDBDataSet.ConstraintsStored: Boolean;
  5225. begin
  5226.   Result := Constraints.Count > 0;
  5227. end;
  5228.  
  5229. { TBatchMove }
  5230.  
  5231. constructor TBatchMove.Create(AOwner: TComponent);
  5232. begin
  5233.   inherited Create(AOwner);
  5234.   FAbortOnKeyViol := True;
  5235.   FAbortOnProblem := True;
  5236.   FTransliterate := True;
  5237.   FMappings := TStringList.Create;
  5238. end;
  5239.  
  5240. destructor TBatchMove.Destroy;
  5241. begin
  5242.   FMappings.Free;
  5243.   inherited Destroy;
  5244. end;
  5245.  
  5246. function TBatchMove.ConvertName(const Name: string; Buffer: PChar): PChar;
  5247. begin
  5248.   if Name <> '' then
  5249.     Result := AnsiToNative(nil, Name, Buffer, 255) else
  5250.     Result := nil;
  5251. end;
  5252.  
  5253. procedure TBatchMove.Execute;
  5254. type
  5255.   PFieldMap = ^TFieldMap;
  5256.   TFieldMap = array[1..1024] of Word;
  5257. var
  5258.   SourceActive, DestinationActive: Boolean;
  5259.   BatchMode: TBatchMode;
  5260.   I: Integer;
  5261.   FieldCount: Word;
  5262.   FieldMap: PFieldMap;
  5263.   DestName, SourceName: string;
  5264.   SKeyViolName, SProblemName, SChangedName: DBITBLNAME;
  5265.  
  5266.   procedure GetMappingNames;
  5267.   var
  5268.     P: Integer;
  5269.     Mapping: string;
  5270.   begin
  5271.     Mapping := FMappings[I];
  5272.     P := Pos('=', Mapping);
  5273.     if P > 0 then
  5274.     begin
  5275.       DestName := Copy(Mapping, 1, P - 1);
  5276.       SourceName := Copy(Mapping, P + 1, 255);
  5277.     end else
  5278.     begin
  5279.       DestName := Mapping;
  5280.       SourceName := Mapping;
  5281.     end;
  5282.   end;
  5283.  
  5284. begin
  5285.   if (Destination = nil) or (Source = nil) or (Destination = Source) then
  5286.     DatabaseError(SInvalidBatchMove);
  5287.   SourceActive := Source.Active;
  5288.   DestinationActive := Destination.Active;
  5289.   FieldCount := 0;
  5290.   FieldMap := nil;
  5291.   try
  5292.     Source.DisableControls;
  5293.     Destination.DisableControls;
  5294.     Source.Open;
  5295.     Source.CheckBrowseMode;
  5296.     Source.UpdateCursorPos;
  5297.     BatchMode := FMode;
  5298.     if BatchMode = batCopy then
  5299.     begin
  5300.       Destination.Close;
  5301.       if FMappings.Count = 0 then
  5302.         Destination.FieldDefs := Source.FieldDefs
  5303.       else
  5304.       begin
  5305.         Destination.FieldDefs.Clear;
  5306.         for I := 0 to FMappings.Count - 1 do
  5307.         begin
  5308.           GetMappingNames;
  5309.           with Source.FieldDefs.Find(SourceName) do
  5310.             Destination.FieldDefs.Add(DestName, DataType, Size, Required);
  5311.         end;
  5312.       end;
  5313.       Destination.IndexDefs.Clear;
  5314.       Destination.CreateTable;
  5315.       BatchMode := batAppend;
  5316.     end;
  5317.     Destination.Open;
  5318.     Destination.CheckBrowseMode;
  5319.     if FMappings.Count <> 0 then
  5320.     begin
  5321.       FieldCount := Destination.FieldDefs.Count;
  5322.       FieldMap := AllocMem(FieldCount * SizeOf(Word));
  5323.       for I := 0 to FMappings.Count - 1 do
  5324.       begin
  5325.         GetMappingNames;
  5326.         FieldMap^[Destination.FieldDefs.Find(DestName).FieldNo] :=
  5327.           Source.FieldDefs.Find(SourceName).FieldNo;
  5328.       end;
  5329.     end;
  5330.     if FRecordCount > 0 then
  5331.     begin
  5332.       Source.UpdateCursorPos;
  5333.       FMovedCount := FRecordCount;
  5334.     end else
  5335.     begin
  5336.       Check(DbiSetToBegin(Source.Handle));
  5337.       FMovedCount := MaxLongint;
  5338.     end;
  5339.     Source.CursorPosChanged;
  5340.     try
  5341.       if CommitCount > 0 then
  5342.         Check(DbiSetProp(hDBIObj(Destination.DBHandle), dbBATCHCOUNT, CommitCount));
  5343.       Check(DbiBatchMove(nil, Source.Handle, nil, Destination.Handle,
  5344.         EBATMode(BatchMode), FieldCount, PWord(FieldMap), nil, nil, 0,
  5345.         ConvertName(FKeyViolTableName, SKeyViolName),
  5346.         ConvertName(FProblemTableName, SProblemName),
  5347.         ConvertName(FChangedTableName, SChangedName),
  5348.         @FProblemCount, @FKeyViolCount, @FChangedCount,
  5349.         FAbortOnProblem, FAbortOnKeyViol, FMovedCount, FTransliterate));
  5350.     finally
  5351.       if DestinationActive then Destination.First;
  5352.     end;
  5353.   finally
  5354.     if FieldMap <> nil then FreeMem(FieldMap, FieldCount * SizeOf(Word));
  5355.     if not DestinationActive then Destination.Close;
  5356.     if not SourceActive then Source.Close;
  5357.     Destination.EnableControls;
  5358.     Source.EnableControls;
  5359.   end;
  5360. end;
  5361.  
  5362. procedure TBatchMove.Notification(AComponent: TComponent;
  5363.   Operation: TOperation);
  5364. begin
  5365.   inherited Notification(AComponent, Operation);
  5366.   if Operation = opRemove then
  5367.   begin
  5368.     if Destination = AComponent then Destination := nil;
  5369.     if Source = AComponent then Source := nil;
  5370.   end;
  5371. end;
  5372.  
  5373. procedure TBatchMove.SetMappings(Value: TStrings);
  5374. begin
  5375.   FMappings.Assign(Value);
  5376. end;
  5377.  
  5378. procedure TBatchMove.SetSource(Value: TBDEDataSet);
  5379. begin
  5380.   FSource := Value;
  5381.   if Value <> nil then Value.FreeNotification(Self);
  5382. end;
  5383.  
  5384. { TIndexFiles }
  5385.  
  5386. constructor TIndexFiles.Create(AOwner: TTable);
  5387. begin
  5388.   inherited Create;
  5389.   FOwner := AOwner;
  5390. end;
  5391.  
  5392. function TIndexFiles.Add(const S: string): Integer;
  5393. begin
  5394.   Result := inherited Add(S);
  5395.   with FOwner do
  5396.   begin
  5397.     if Active then OpenIndexFile(S);
  5398.     FIndexDefs.Updated := False;
  5399.   end;
  5400. end;
  5401.  
  5402. procedure TIndexFiles.Clear;
  5403. var
  5404.   I: Integer;
  5405. begin
  5406.   with FOwner do
  5407.     if Active then
  5408.       for I := 0 to Count - 1 do CloseIndexFile(Strings[I]);
  5409.   inherited Clear;
  5410. end;
  5411.  
  5412. procedure TIndexFiles.Insert(Index: Integer; const S: string);
  5413. begin
  5414.   inherited Insert(Index, S);
  5415.   with FOwner do
  5416.   begin
  5417.     if Active then OpenIndexFile(S);
  5418.     FIndexDefs.Updated := False;
  5419.   end;
  5420. end;
  5421.  
  5422. procedure TIndexFiles.Delete(Index: Integer);
  5423. begin
  5424.   with FOwner do
  5425.   begin
  5426.     if Active then CloseIndexFile(Strings[Index]);
  5427.     FIndexDefs.Updated := False;
  5428.   end;
  5429.   inherited Delete(Index);
  5430. end;
  5431.  
  5432. { TTable }
  5433.  
  5434. constructor TTable.Create(AOwner: TComponent);
  5435. begin
  5436.   inherited Create(AOwner);
  5437.   FIndexDefs := TIndexDefs.Create(Self);
  5438.   FMasterLink := TMasterDataLink.Create(Self);
  5439.   FMasterLink.OnMasterChange := MasterChanged;
  5440.   FMasterLink.OnMasterDisable := MasterDisabled;
  5441.   FIndexFiles := TIndexFiles.Create(Self);
  5442. end;
  5443.  
  5444. destructor TTable.Destroy;
  5445. begin
  5446.   FIndexFiles.Free;
  5447.   FMasterLink.Free;
  5448.   FIndexDefs.Free;
  5449.   inherited Destroy;
  5450. end;
  5451.  
  5452. function TTable.GetHandle(const IndexName, IndexTag: string): HDBICur;
  5453. const
  5454.   OpenModes: array[Boolean] of DbiOpenMode = (dbiReadWrite, dbiReadOnly);
  5455.   ShareModes: array[Boolean] of DbiShareMode = (dbiOpenShared, dbiOpenExcl);
  5456. var
  5457.   STableName: array[0..DBIMAXTBLNAMELEN - 1] of Char;
  5458.   SIndexName: array[0..DBIMAXTBLNAMELEN - 1] of Char;
  5459.   OpenMode: DbiOpenMode;
  5460.   RetCode: DbiResult;
  5461.   I: Integer;
  5462. begin
  5463.   AnsiToNative(DBLocale, FTableName, STableName, SizeOf(STableName) - 1);
  5464.   Result := nil;
  5465.   OpenMode := OpenModes[FReadOnly or ForceUpdateCallback];
  5466.   while True do
  5467.   begin
  5468.     RetCode := DbiOpenTable(DBHandle, STableName, GetTableTypeName,
  5469.       PChar(IndexName), PChar(IndexTag), 0, OpenMode, ShareModes[FExclusive],
  5470.       xltField, False, nil, Result);
  5471.     if RetCode = DBIERR_TABLEREADONLY then
  5472.       OpenMode := dbiReadOnly
  5473.     else if CheckOpen(RetCode) then Break;
  5474.   end;
  5475.   if IsDBaseTable then
  5476.     for I := 0 to IndexFiles.Count - 1 do
  5477.     begin
  5478.       CharToOem(PChar(IndexFiles[I]), SIndexName);
  5479.       CheckIndexOpen(DbiOpenIndex(Result, SIndexName, 0));
  5480.     end;
  5481. end;
  5482.  
  5483. function TTable.CreateHandle: HDBICur;
  5484. var
  5485.   IndexName, IndexTag: string;
  5486. begin
  5487.   if FTableName = '' then DatabaseError(SNoTableName);
  5488.   GetIndexParams(FIndexName, FFieldsIndex, IndexName, IndexTag);
  5489.   if IsProductionIndex(IndexName) then
  5490.     Result := GetHandle(IndexName, IndexTag) else
  5491.     Result := GetHandle('', '');
  5492. end;
  5493.  
  5494. function TTable.GetLanguageDriverName: string;
  5495. const
  5496.   Names: array[TTableType] of string =
  5497.     (szPARADOX, szPARADOX, szDBASE, szASCII);
  5498. var
  5499.   Buffer: DBITBLNAME;
  5500.   S, DriverName: string;
  5501.   Database: TDatabase;
  5502. begin
  5503.   Buffer[0] := #0;
  5504.   DriverName := '';
  5505.   Database := DBSession.OpenDatabase(DatabaseName);
  5506.   try
  5507.     if Database.IsSQLBased then
  5508.     begin
  5509.       DriverName := DBSession.GetAliasDriverName(DatabaseName);
  5510.       FmtStr(S, ':%s:%s', [DatabaseName, TableName]);
  5511.       AnsiToNative(DBLocale, S, Buffer, SizeOf(Buffer) - 1);
  5512.     end
  5513.     else begin
  5514.       AnsiToNative(DBLocale, TableName, Buffer, SizeOf(Buffer) - 1);
  5515.       DbiFormFullName(Database.Handle, Buffer, nil, Buffer);
  5516.       if (TableType <> ttDefault) or
  5517.         (ExtractFileExt(TableName) = '') then
  5518.         DriverName := Names[TableType]
  5519.       else if IsDBaseTable then
  5520.         DriverName := szDBASE else
  5521.         DriverName := szPARADOX;
  5522.     end;
  5523.     if DbiGetLdName(PChar(DriverName), @Buffer, @Buffer) <> 0 then
  5524.       Buffer := #0;
  5525.   finally
  5526.     DBSession.CloseDatabase(Database);
  5527.   end;
  5528.   Result := Buffer;
  5529. end;
  5530.  
  5531. function TTable.SetTempLocale(ActiveCheck: Boolean): TLocale;
  5532. var
  5533.   LName: string;
  5534.   TempLocale: TLocale;
  5535. begin
  5536.   Result := Locale;
  5537.   if not (ActiveCheck and Active) then
  5538.   begin
  5539.     LName := GetLanguageDriverName;
  5540.     if (LName <> '') and (OsLdLoadBySymbName(PChar(LName), TempLocale) = 0) then
  5541.       if TempLocale <> Locale then
  5542.         SetLocale(TempLocale) else
  5543.         OsLdUnloadObj(TempLocale);
  5544.   end;
  5545. end;
  5546.  
  5547. procedure TTable.RestoreLocale(LocaleSave: TLocale);
  5548. begin
  5549.   if (LocaleSave <> Locale) and (Locale <> nil) then
  5550.   begin
  5551.     OsLdUnloadObj(FLocale);
  5552.     SetLocale(LocaleSave);
  5553.   end;
  5554. end;
  5555.  
  5556. procedure TTable.PrepareCursor;
  5557. var
  5558.   IndexName, IndexTag: string;
  5559. begin
  5560.   GetIndexParams(FIndexName, FFieldsIndex, IndexName, IndexTag);
  5561.   if not IsProductionIndex(IndexName) then SwitchToIndex(IndexName, IndexTag);
  5562.   CheckMasterRange;
  5563. end;
  5564.  
  5565. procedure TTable.InitFieldDefs;
  5566. var
  5567.   FieldNo: Word;
  5568.   FCursor, VCursor: HDBICur;
  5569.   RequiredFields: set of 0..255;
  5570.   STableName: array[0..DBIMAXTBLNAMELEN - 1] of Char;
  5571.   FieldDesc: FLDDesc;
  5572.   ValCheckDesc: VCHKDesc;
  5573.   LocaleSave: TLocale;
  5574. begin
  5575.   SetDBFlag(dbfFieldList, True);
  5576.   try
  5577.     if FTableName = '' then DatabaseError(SNoTableName);
  5578.     AnsiToNative(DBLocale, TableName, STableName, SizeOf(STableName) - 1);
  5579.     RequiredFields := [];
  5580.     LocaleSave := SetTempLocale(True);
  5581.     try
  5582.       while not CheckOpen(DbiOpenFieldList(DBHandle, STableName,
  5583.         GetTableTypeName, False, FCursor)) do {Retry};
  5584.       try
  5585.         if DbiOpenVChkList(DBHandle, STableName, GetTableTypeName,
  5586.           VCursor) = 0 then
  5587.         begin
  5588.           while DbiGetNextRecord(VCursor, dbiNoLock, @ValCheckDesc, nil) = 0 do
  5589.             if ValCheckDesc.bRequired then
  5590.               Include(RequiredFields, ValCheckDesc.iFldNum - 1);
  5591.           DbiCloseCursor(VCursor);
  5592.         end;
  5593.         FieldNo := 0;
  5594.         FieldDefs.Clear;
  5595.         while DbiGetNextRecord(FCursor, dbiNoLock, @FieldDesc, nil) = 0 do
  5596.         begin
  5597.           AddFieldDesc(FieldDesc, FieldNo in RequiredFields,  FieldNo + 1);
  5598.           Inc(FieldNo);
  5599.         end;
  5600.       finally
  5601.         DbiCloseCursor(FCursor);
  5602.       end;
  5603.     finally
  5604.       RestoreLocale(LocaleSave);
  5605.     end;
  5606.   finally
  5607.     SetDBFlag(dbfFieldList, False);
  5608.   end;
  5609. end;
  5610.  
  5611. procedure TTable.DestroyHandle;
  5612. begin
  5613.   DestroyLookupCursor;
  5614.   inherited DestroyHandle;
  5615. end;
  5616.  
  5617. { Index / Ranges / Keys }
  5618.  
  5619. procedure TTable.DecodeIndexDesc(const IndexDesc: IDXDesc;
  5620.   var Source, Name, Fields: string; var Options: TIndexOptions);
  5621. var
  5622.   IndexOptions: TIndexOptions;
  5623.   I: Integer;
  5624.   SSource, SName: PChar;
  5625. begin
  5626.   with IndexDesc do
  5627.   begin
  5628.     if szTagName[0] = #0 then
  5629.     begin
  5630.       SName := szName;
  5631.       Source := '';
  5632.     end
  5633.     else begin
  5634.       SSource := szName;
  5635.       SName := szTagName;
  5636.       NativeToAnsi(nil, SSource, Source);
  5637.     end;
  5638.     NativeToAnsi(Locale, SName, Name);
  5639.     Name := ExtractFileName(Name);
  5640.     Source := ExtractFileName(Source);
  5641.     IndexOptions := [];
  5642.     if bPrimary then Include(IndexOptions, ixPrimary);
  5643.     if bUnique then Include(IndexOptions, ixUnique);
  5644.     if bDescending then Include(IndexOptions, ixDescending);
  5645.     if bCaseInsensitive then Include(IndexOptions, ixCaseInsensitive);
  5646.     if bExpIdx then
  5647.     begin
  5648.       Include(IndexOptions, ixExpression);
  5649.       NativeToAnsi(Locale, szKeyExp, Fields);
  5650.     end else
  5651.     begin
  5652.       Fields := '';
  5653.       for I := 0 to iFldsInKey - 1 do
  5654.       begin
  5655.         if I <> 0 then Fields := Fields + ';';
  5656.         Fields := Fields + FieldDefs[aiKeyFld[I] - 1].Name;
  5657.       end;
  5658.     end;
  5659.     Options := IndexOptions;
  5660.   end;
  5661. end;
  5662.  
  5663. procedure TTable.EncodeIndexDesc(var IndexDesc: IDXDesc;
  5664.   const Name, Fields: string; Options: TIndexOptions);
  5665. var
  5666.   Pos: Integer;
  5667. begin
  5668.   FillChar(IndexDesc, SizeOf(IndexDesc), 0);
  5669.   with IndexDesc do
  5670.   begin
  5671.     if IsDBaseTable then
  5672.       AnsiToNative(Locale, Name, szTagName, SizeOf(szTagName) - 1)
  5673.     else
  5674.       AnsiToNative(Locale, Name, szName, SizeOf(szName) - 1);
  5675.     bPrimary := ixPrimary in Options;
  5676.     bUnique := ixUnique in Options;
  5677.     bDescending := ixDescending in Options;
  5678.     bMaintained := True;
  5679.     bCaseInsensitive := ixCaseInsensitive in Options;
  5680.     if ixExpression in Options then
  5681.     begin
  5682.       bExpIdx := True;
  5683.       AnsiToNative(Locale, Fields, szKeyExp, SizeOf(szKeyExp) - 1);
  5684.     end else
  5685.     begin
  5686.       Pos := 1;
  5687.       while (Pos <= Length(Fields)) and (iFldsInKey < DBIMAXFLDSINKEY) do
  5688.       begin
  5689.         aiKeyFld[iFldsInKey] :=
  5690.           FieldDefs.Find(ExtractFieldName(Fields, Pos)).FieldNo;
  5691.         Inc(iFldsInKey);
  5692.       end;
  5693.     end;
  5694.   end;
  5695. end;
  5696.  
  5697. procedure TTable.AddIndex(const Name, Fields: string;
  5698.   Options: TIndexOptions);
  5699. var
  5700.   STableName: DBITBLNAME;
  5701.   IndexDesc: IDXDesc;
  5702.   LocaleSave: TLocale;
  5703. begin
  5704.   FieldDefs.Update;
  5705.   if Active then
  5706.   begin
  5707.     EncodeIndexDesc(IndexDesc, Name, Fields, Options);
  5708.     CheckBrowseMode;
  5709.     CursorPosChanged;
  5710.     Check(DbiAddIndex(DBHandle, Handle, nil, nil, IndexDesc, nil));
  5711.   end else
  5712.   begin
  5713.     LocaleSave := SetTempLocale(False);
  5714.     try
  5715.       EncodeIndexDesc(IndexDesc, Name, Fields, Options);
  5716.     finally
  5717.       RestoreLocale(LocaleSave);
  5718.     end;
  5719.     SetDBFlag(dbfTable, True);
  5720.     try
  5721.       Check(DbiAddIndex(DBHandle, nil, AnsiToNative(DBLocale, TableName,
  5722.         STableName, SizeOf(STableName) - 1), GetTableTypeName,
  5723.         IndexDesc, nil));
  5724.     finally
  5725.       SetDBFlag(dbfTable, False);
  5726.     end;
  5727.   end;
  5728.   FIndexDefs.Updated := False;
  5729. end;
  5730.  
  5731. procedure TTable.DeleteIndex(const Name: string);
  5732. var
  5733.   STableName: array[0..DBIMAXTBLNAMELEN - 1] of Char;
  5734.   IndexName, IndexTag: string;
  5735. begin
  5736.   if Active then
  5737.   begin
  5738.     GetIndexParams(Name, False, IndexName, IndexTag);
  5739.     CheckBrowseMode;
  5740.     Check(DbiDeleteIndex(DBHandle, Handle, nil, nil, PChar(IndexName),
  5741.       PChar(IndexTag), 0));
  5742.   end else
  5743.   begin
  5744.     GetIndexParams(Name, False, IndexName, IndexTag);
  5745.     SetDBFlag(dbfTable, True);
  5746.     try
  5747.       Check(DbiDeleteIndex(DBHandle, nil, AnsiToNative(DBLocale, TableName,
  5748.         STableName, SizeOf(STableName) - 1), GetTableTypeName,
  5749.         PChar(IndexName), PChar(IndexTag), 0));
  5750.     finally
  5751.       SetDBFlag(dbfTable, False);
  5752.     end;
  5753.   end;
  5754.   FIndexDefs.Updated := False;
  5755. end;
  5756.  
  5757. function TTable.GetIndexFieldNames: string;
  5758. begin
  5759.   if FFieldsIndex then Result := FIndexName else Result := '';
  5760. end;
  5761.  
  5762. function TTable.GetIndexName: string;
  5763. begin
  5764.   if FFieldsIndex then Result := '' else Result := FIndexName;
  5765. end;
  5766.  
  5767. procedure TTable.GetIndexNames(List: TStrings);
  5768. var
  5769.   I: Integer;
  5770. begin
  5771.   UpdateIndexDefs;
  5772.   List.BeginUpdate;
  5773.   try
  5774.     List.Clear;
  5775.     for I := 0 to FIndexDefs.Count - 1 do
  5776.       with FIndexDefs[I] do
  5777.         if Name <> '' then List.Add(Name);
  5778.   finally
  5779.     List.EndUpdate;
  5780.   end;
  5781. end;
  5782.  
  5783. procedure TTable.GetIndexParams(const IndexName: string;
  5784.   FieldsIndex: Boolean; var IndexedName, IndexTag: string);
  5785. var
  5786.   I: Integer;
  5787.   IndexStr: TIndexName;
  5788.   SIndexName: array[0..127] of Char;
  5789.   SIndexTag: DBINAME;
  5790.   LocaleSave: TLocale;
  5791. begin
  5792.   SIndexName[0] := #0;
  5793.   SIndexTag[0] := #0;
  5794.   if IndexName <> '' then
  5795.   begin
  5796.     UpdateIndexDefs;
  5797.     IndexStr := IndexName;
  5798.     LocaleSave := SetTempLocale(True);
  5799.     try
  5800.       if FieldsIndex then
  5801.         if Database.IsSQLBased then
  5802.         begin
  5803.           for I := 1 to Length(IndexStr) do
  5804.             if IndexStr[I] = ';' then IndexStr[I] := '@';
  5805.           IndexStr := '@' + IndexStr;
  5806.         end else
  5807.           IndexStr := IndexDefs.FindIndexForFields(IndexName).Name;
  5808.       if IsDBaseTable then
  5809.       begin
  5810.         if UpperCase(ExtractFileExt(IndexStr)) <> '.NDX' then
  5811.         begin
  5812.           AnsiToNative(Locale, IndexStr, SIndexTag, SizeOf(SIndexTag) - 1);
  5813.           with IndexDefs do
  5814.           begin
  5815.             I := IndexOf(IndexStr);
  5816.             if I <> -1 then
  5817.               IndexStr := Items[I].Source else
  5818.               DatabaseErrorFmt(SIndexDoesNotExist, [IndexName]);
  5819.             AnsiToNative(nil, IndexStr, SIndexName, SizeOf(SIndexName) - 1);
  5820.           end;
  5821.         end;
  5822.       end else
  5823.         AnsiToNative(Locale, IndexStr, SIndexName, SizeOf(SIndexName) - 1);
  5824.     finally
  5825.       RestoreLocale(LocaleSave);
  5826.     end;
  5827.   end;
  5828.   IndexedName := SIndexName;
  5829.   IndexTag := SIndexTag;
  5830. end;
  5831.  
  5832. procedure TTable.SetIndex(const Value: string; FieldsIndex: Boolean);
  5833. var
  5834.   IndexName, IndexTag: string;
  5835. begin
  5836.   if Active then CheckBrowseMode;
  5837.   if (FIndexName <> Value) or (FFieldsIndex <> FieldsIndex) then
  5838.   begin
  5839.     if Active then
  5840.     begin
  5841.       GetIndexParams(Value, FieldsIndex, IndexName, IndexTag);
  5842.       SwitchToIndex(IndexName, IndexTag);
  5843.       CheckMasterRange;
  5844.     end;
  5845.     FIndexName := Value;
  5846.     FFieldsIndex := FieldsIndex;
  5847.     if Active then Resync([]);
  5848.   end;
  5849. end;
  5850.  
  5851. procedure TTable.SetIndexFieldNames(const Value: string);
  5852. begin
  5853.   SetIndex(Value, Value <> '');
  5854. end;
  5855.  
  5856. procedure TTable.SetIndexName(const Value: string);
  5857. begin
  5858.   SetIndex(Value, False);
  5859. end;
  5860.  
  5861. procedure TTable.SetIndexFiles(Value: TStrings);
  5862. begin
  5863.   FIndexFiles.Assign(Value);
  5864. end;
  5865.  
  5866. procedure TTable.OpenIndexFile(const IndexName: string);
  5867. var
  5868.   Buffer: array[0..DBIMAXNAMELEN - 1] of char;
  5869. begin
  5870.   CheckIndexOpen(DbiOpenIndex(Handle,
  5871.     AnsiToNative(Locale, IndexName, Buffer, SizeOf(Buffer) - 1), 0));
  5872. end;
  5873.  
  5874. procedure TTable.CloseIndexFile(const IndexFileName: string);
  5875. var
  5876.   IndexName, IndexTag: string;
  5877.   Buffer: array[0..DBIMAXNAMELEN - 1] of char;
  5878. begin
  5879.   GetIndexParams(FIndexName, FFieldsIndex, IndexName, IndexTag);
  5880.   if AnsiUpperCase(IndexName) = AnsiUpperCase(IndexFileName) then
  5881.     Self.IndexName := '';
  5882.   Check(DbiCloseIndex(Handle,
  5883.     AnsiToNative(Locale, IndexFileName, Buffer, SizeOf(Buffer) - 1), 0));
  5884. end;
  5885.  
  5886. procedure TTable.UpdateIndexDefs;
  5887. var
  5888.   Options: TIndexOptions;
  5889.   Name, Source, Fields: string;
  5890.   CursorProps: CurProps;
  5891.   Cursor: HDBICur;
  5892.   IndexBuff: PIndexDescList;
  5893.   I: Integer;
  5894.   NumIndexes: Word;
  5895.   OldLocale, CursorLocale: TLocale;
  5896. begin
  5897.   { ! Investigate using DbiOpenIndexList for this instead of opening the cursor. }
  5898.   if not FIndexDefs.Updated then
  5899.   begin
  5900.     SetDBFlag(dbfIndexList, True);
  5901.     try
  5902.       FieldDefs.Update;
  5903.       OldLocale := Locale;
  5904.       if Handle = nil then
  5905.       begin
  5906.         Cursor := GetHandle('', '');
  5907.         if DbiGetLdObj(Cursor, CursorLocale) = 0 then SetLocale(CursorLocale);
  5908.       end else
  5909.         Cursor := Handle;
  5910.       try
  5911.         DbiGetCursorProps(Cursor, CursorProps);
  5912.         NumIndexes := CursorProps.iIndexes;
  5913.         IndexBuff := AllocMem(NumIndexes * SizeOf(IDXDesc));
  5914.         try
  5915.           IndexDefs.Clear;
  5916.           DbiGetIndexDescs(Cursor, PIDXDesc(IndexBuff));
  5917.           for I := 0 to NumIndexes - 1 do
  5918.           begin
  5919.             DecodeIndexDesc(IndexBuff^[I], Source, Name, Fields, Options);
  5920.             with IndexDefs do
  5921.             begin
  5922.               Add(Name, Fields, Options);
  5923.               if Source <> '' then Items[Count - 1].Source := Source;
  5924.             end;
  5925.           end;
  5926.           IndexDefs.Updated := True;
  5927.         finally
  5928.           FreeMem(IndexBuff, NumIndexes * SizeOf(IDXDesc));
  5929.         end;
  5930.       finally
  5931.         if (Cursor <> nil) and (Cursor <> Handle) then DbiCloseCursor(Cursor);
  5932.         if Locale <> OldLocale then SetLocale(OldLocale);
  5933.       end;
  5934.     finally
  5935.       SetDBFlag(dbfIndexList, False);
  5936.     end;
  5937.   end;
  5938. end;
  5939.  
  5940. function TTable.IsProductionIndex(const IndexName: string): Boolean;
  5941. begin
  5942.   Result := True;
  5943.   if IsDBaseTable and (IndexName <> '') then
  5944.     if AnsiUpperCase(ExtractFileExt(IndexName)) = '.NDX' then
  5945.       Result := False
  5946.     else Result := AnsiUpperCase(ChangeFileExt(TableName, '')) =
  5947.       AnsiUpperCase(ChangeFileExt(IndexName, ''));
  5948. end;
  5949.  
  5950. function TTable.FindKey(const KeyValues: array of const): Boolean;
  5951. begin
  5952.   CheckBrowseMode;
  5953.   SetKeyFields(kiLookup, KeyValues);
  5954.   Result := GotoKey;
  5955. end;
  5956.  
  5957. procedure TTable.FindNearest(const KeyValues: array of const);
  5958. begin
  5959.   CheckBrowseMode;
  5960.   SetKeyFields(kiLookup, KeyValues);
  5961.   GotoNearest;
  5962. end;
  5963.  
  5964. function TTable.GotoKey: Boolean;
  5965. var
  5966.   KeyBuffer: PKeyBuffer;
  5967.   IndexBuffer, RecBuffer: PChar;
  5968.   UseKey: Boolean;
  5969. begin
  5970.   CheckBrowseMode;
  5971.   CursorPosChanged;
  5972.   KeyBuffer := GetKeyBuffer(kiLookup);
  5973.   IndexBuffer := AllocMem(KeySize);
  5974.   try
  5975.     RecBuffer := PChar(KeyBuffer) + SizeOf(TKeyBuffer);
  5976.     UseKey := DbiExtractKey(Handle, RecBuffer, IndexBuffer) = 0;
  5977.     if UseKey then RecBuffer := IndexBuffer;
  5978.     Result := DbiGetRecordForKey(Handle, UseKey, KeyBuffer^.FieldCount, 0,
  5979.       RecBuffer, nil) = 0;
  5980.     if Result then Resync([rmExact, rmCenter]);
  5981.   finally
  5982.     FreeMem(IndexBuffer, KeySize);
  5983.   end;
  5984. end;
  5985.  
  5986. procedure TTable.GotoNearest;
  5987. var
  5988.   SearchCond: DBISearchCond;
  5989.   KeyBuffer: PKeyBuffer;
  5990.   IndexBuffer, RecBuffer: PChar;
  5991.   UseKey: Boolean;
  5992. begin
  5993.   CheckBrowseMode;
  5994.   CursorPosChanged;
  5995.   KeyBuffer := GetKeyBuffer(kiLookup);
  5996.   if KeyBuffer^.Exclusive then
  5997.     SearchCond := keySEARCHGT else
  5998.     SearchCond := keySEARCHGEQ;
  5999.   IndexBuffer := AllocMem(KeySize);
  6000.   try
  6001.     RecBuffer := PChar(KeyBuffer) + SizeOf(TKeyBuffer);
  6002.     UseKey := DbiExtractKey(Handle, RecBuffer, IndexBuffer) = 0;
  6003.     if UseKey then RecBuffer := IndexBuffer;
  6004.     Check(DbiSetToKey(Handle, SearchCond, UseKey, KeyBuffer^.FieldCount, 0,
  6005.       RecBuffer));
  6006.     Resync([rmCenter]);
  6007.   finally
  6008.     FreeMem(IndexBuffer, KeySize);
  6009.   end;
  6010. end;
  6011.  
  6012. procedure TTable.SetKey;
  6013. begin
  6014.   SetKeyBuffer(kiLookup, True);
  6015. end;
  6016.  
  6017. procedure TTable.EditKey;
  6018. begin
  6019.   SetKeyBuffer(kiLookup, False);
  6020. end;
  6021.  
  6022. procedure TTable.ApplyRange;
  6023. begin
  6024.   CheckBrowseMode;
  6025.   if SetCursorRange then First;
  6026. end;
  6027.  
  6028. procedure TTable.CancelRange;
  6029. begin
  6030.   CheckBrowseMode;
  6031.   UpdateCursorPos;
  6032.   if ResetCursorRange then Resync([]);
  6033. end;
  6034.  
  6035. procedure TTable.SetRange(const StartValues, EndValues: array of const);
  6036. begin
  6037.   CheckBrowseMode;
  6038.   SetKeyFields(kiRangeStart, StartValues);
  6039.   SetKeyFields(kiRangeEnd, EndValues);
  6040.   ApplyRange;
  6041. end;
  6042.  
  6043. procedure TTable.SetRangeEnd;
  6044. begin
  6045.   SetKeyBuffer(kiRangeEnd, True);
  6046. end;
  6047.  
  6048. procedure TTable.SetRangeStart;
  6049. begin
  6050.   SetKeyBuffer(kiRangeStart, True);
  6051. end;
  6052.  
  6053. procedure TTable.EditRangeEnd;
  6054. begin
  6055.   SetKeyBuffer(kiRangeEnd, False);
  6056. end;
  6057.  
  6058. procedure TTable.EditRangeStart;
  6059. begin
  6060.   SetKeyBuffer(kiRangeStart, False);
  6061. end;
  6062.  
  6063. procedure TTable.UpdateRange;
  6064. begin
  6065.   SetLinkRanges(FMasterLink.Fields);
  6066. end;
  6067.  
  6068. function TTable.GetLookupCursor(const KeyFields: string;
  6069.   CaseInsensitive: Boolean): HDBICur;
  6070. var
  6071.   IndexFound, FieldsIndex: Boolean;
  6072.   KeyIndexName, IndexName, IndexTag: string;
  6073.   KeyIndex: TIndexDef;
  6074. begin
  6075.   if (KeyFields <> FLookupKeyFields) or
  6076.      (CaseInsensitive <> FLookupCaseIns) then
  6077.   begin
  6078.     DestroyLookupCursor;
  6079.     IndexFound := False;
  6080.     FieldsIndex := False;
  6081.     if Database.IsSQLBased then
  6082.     begin
  6083.       if not CaseInsensitive then
  6084.       begin
  6085.         KeyIndexName := KeyFields;
  6086.         FieldsIndex := True;
  6087.         IndexFound := True;
  6088.       end;
  6089.     end else
  6090.     begin
  6091.       KeyIndex := IndexDefs.GetIndexForFields(KeyFields, CaseInsensitive);
  6092.       if KeyIndex <> nil then
  6093.       begin
  6094.         KeyIndexName := KeyIndex.Name;
  6095.         FieldsIndex := False;
  6096.         IndexFound := True;
  6097.       end;
  6098.     end;
  6099.     if IndexFound then
  6100.     begin
  6101.       Check(DbiCloneCursor(Handle, True, False, FLookupHandle));
  6102.       GetIndexParams(KeyIndexName, FieldsIndex, IndexName, IndexTag);
  6103.       Check(DbiSwitchToIndex(FLookupHandle, PChar(IndexName),
  6104.         PChar(IndexTag), 0, False));
  6105.     end;
  6106.     FLookupKeyFields := KeyFields;
  6107.     FLookupCaseIns := CaseInsensitive;
  6108.   end;
  6109.   Result := FLookupHandle;
  6110. end;
  6111.  
  6112. procedure TTable.DestroyLookupCursor;
  6113. begin
  6114.   if FLookupHandle <> nil then
  6115.   begin
  6116.     DbiCloseCursor(FLookupHandle);
  6117.     FLookupHandle := nil;
  6118.     FLookupKeyFields := '';
  6119.   end;
  6120. end;
  6121.  
  6122. procedure TTable.GotoCurrent(Table: TTable);
  6123. begin
  6124.   CheckBrowseMode;
  6125.   Table.CheckBrowseMode;
  6126.   if (AnsiCompareText(DatabaseName, Table.DatabaseName) <> 0) or
  6127.     (AnsiCompareText(TableName, Table.TableName) <> 0) then
  6128.     DatabaseError(STableMismatch);
  6129.   Table.UpdateCursorPos;
  6130.   Check(DbiSetToCursor(Handle, Table.Handle));
  6131.   Resync([rmExact, rmCenter]);
  6132. end;
  6133.  
  6134. { Master / Detail }
  6135.  
  6136. procedure TTable.CheckMasterRange;
  6137. begin
  6138.   if FMasterLink.Active and (FMasterLink.Fields.Count > 0) then
  6139.   begin
  6140.     SetLinkRanges(FMasterLink.Fields);
  6141.     SetCursorRange;
  6142.   end;
  6143. end;
  6144.  
  6145. procedure TTable.MasterChanged(Sender: TObject);
  6146. begin
  6147.   CheckBrowseMode;
  6148.   UpdateRange;
  6149.   ApplyRange;
  6150. end;
  6151.  
  6152. procedure TTable.MasterDisabled(Sender: TObject);
  6153. begin
  6154.   CancelRange;
  6155. end;
  6156.  
  6157. function TTable.GetDataSource: TDataSource;
  6158. begin
  6159.   Result := FMasterLink.DataSource;
  6160. end;
  6161.  
  6162. procedure TTable.SetDataSource(Value: TDataSource);
  6163. begin
  6164.   if IsLinkedTo(Value) then DatabaseError(SCircularDataLink);
  6165.   FMasterLink.DataSource := Value;
  6166. end;
  6167.  
  6168. function TTable.GetMasterFields: string;
  6169. begin
  6170.   Result := FMasterLink.FieldNames;
  6171. end;
  6172.  
  6173. procedure TTable.SetMasterFields(const Value: string);
  6174. begin
  6175.   FMasterLink.FieldNames := Value;
  6176. end;
  6177.  
  6178. procedure TTable.DoOnNewRecord;
  6179. var
  6180.   I: Integer;
  6181. begin
  6182.   if FMasterLink.Active and (FMasterLink.Fields.Count > 0) then
  6183.     for I := 0 to FMasterLink.Fields.Count - 1 do
  6184.       IndexFields[I] := TField(FMasterLink.Fields[I]);
  6185.   inherited DoOnNewRecord;
  6186. end;
  6187.  
  6188. { Table Manipulation }
  6189.  
  6190. function TTable.BatchMove(ASource: TBDEDataSet; AMode: TBatchMode): Longint;
  6191. begin
  6192.   with TBatchMove.Create(nil) do
  6193.   try
  6194.     Destination := Self;
  6195.     Source := ASource;
  6196.     Mode := AMode;
  6197.     Execute;
  6198.     Result := MovedCount;
  6199.   finally
  6200.     Free;
  6201.   end;
  6202. end;
  6203.  
  6204. procedure TTable.CreateTable;
  6205. var
  6206.   I: Integer;
  6207.   FieldDescs: PFLDDesc;
  6208.   ValCheckPtr: PVCHKDesc;
  6209.   DriverTypeName: DBINAME;
  6210.   TableDesc: CRTblDesc;
  6211.   LName: string;
  6212.   TempLocale, OldLocale: TLocale;
  6213.   SQLLName: DBIName;
  6214.   PSQLLName: PChar;
  6215.   LvlFldDesc: FLDDesc;
  6216.   Level: DBINAME;
  6217.  
  6218.   function GetStandardLanguageDriver: string;
  6219.   var
  6220.     DriverName: string;
  6221.     Buffer: array[0..DBIMAXNAMELEN - 1] of char;
  6222.   begin
  6223.     if not Database.IsSQLBased then
  6224.     begin
  6225.       DriverName := GetTableTypeName;
  6226.       if DriverName = '' then
  6227.         if IsDBaseTable then
  6228.           DriverName := szDBASE else
  6229.           DriverName := szPARADOX;
  6230.       if DbiGetLdName(PChar(DriverName), nil, Buffer) = 0 then
  6231.         Result := Buffer;
  6232.     end
  6233.     else Result := '';
  6234.   end;
  6235.  
  6236. begin
  6237.   CheckInactive;
  6238.   if FieldDefs.Count = 0 then
  6239.     for I := 0 to FieldCount - 1 do
  6240.       with Fields[I] do
  6241.         if FieldKind = fkData then
  6242.           FieldDefs.Add(FieldName, DataType, Size, Required);
  6243.   FieldDescs := nil;
  6244.   FillChar(TableDesc, SizeOf(TableDesc), 0);
  6245.   with TableDesc do
  6246.   begin
  6247.     SetDBFlag(dbfTable, True);
  6248.     try
  6249.       AnsiToNative(Locale, TableName, szTblName, SizeOf(szTblName) - 1);
  6250.       if GetTableTypeName <> nil then
  6251.         StrCopy(szTblType, GetTableTypeName);
  6252.       iFldCount := FieldDefs.Count;
  6253.       FieldDescs := AllocMem(iFldCount * SizeOf(FLDDesc));
  6254.       TempLocale := nil;
  6255.       LName := GetStandardLanguageDriver;
  6256.       OldLocale := Locale;
  6257.       if (LName <> '') and (OsLdLoadBySymbName(PChar(LName), TempLocale) = 0) then
  6258.         SetLocale(TempLocale);
  6259.       try
  6260.         for I := 0 to FieldDefs.Count - 1 do
  6261.           with FieldDefs[I] do
  6262.           begin
  6263.             EncodeFieldDesc(PFieldDescList(FieldDescs)^[I], Name,
  6264.               DataType, Size);
  6265.             if Required then Inc(iValChkCount);
  6266.           end;
  6267.       finally
  6268.         if TempLocale <> nil then
  6269.         begin
  6270.           OsLdUnloadObj(TempLocale);
  6271.           SetLocale(OldLocale);
  6272.         end;
  6273.       end;
  6274.       pFldDesc := AllocMem(iFldCount * SizeOf(FLDDesc));
  6275.       PSQLLName := nil;
  6276.       if Database.IsSQLBased then
  6277.         if DbiGetLdNameFromDB(DBHandle, nil, SQLLName) = 0 then
  6278.           PSQLLName := SQLLName;
  6279.       Check(DbiTranslateRecordStructure(nil, iFldCount, FieldDescs,
  6280.         GetDriverTypeName(DriverTypeName), PSQLLName, pFLDDesc, False));
  6281.       iIdxCount := IndexDefs.Count;
  6282.       pIdxDesc := AllocMem(iIdxCount * SizeOf(IDXDesc));
  6283.       for I := 0 to IndexDefs.Count - 1 do
  6284.         with IndexDefs[I] do
  6285.           EncodeIndexDesc(PIndexDescList(pIdxDesc)^[I], Name, Fields,
  6286.             Options);
  6287.       if iValChkCount <> 0 then
  6288.       begin
  6289.         pVChkDesc := AllocMem(iValChkCount * SizeOf(VCHKDesc));
  6290.         ValCheckPtr := pVChkDesc;
  6291.         for I := 0 to FieldDefs.Count - 1 do
  6292.           if FieldDefs[I].Required then
  6293.           begin
  6294.             ValCheckPtr^.iFldNum := I + 1;
  6295.             ValCheckPtr^.bRequired := True;
  6296.             Inc(ValCheckPtr);
  6297.           end;
  6298.       end;
  6299.  
  6300.       if FTableLevel > 0 then
  6301.       with TableDesc do
  6302.       begin
  6303.         iOptParams := 1;
  6304.         StrCopy(@Level, PChar(IntToStr(FTableLevel)));
  6305.         pOptData := @Level;
  6306.         StrCopy(LvlFldDesc.szName, szCFGDRVLEVEL);
  6307.         LvlFldDesc.iLen := StrLen(Level);
  6308.         LvlFldDesc.iOffset := 0;
  6309.         pfldOptParams :=  @LvlFldDesc;
  6310.       end;
  6311.       Check(DbiCreateTable(DBHandle, True, TableDesc));
  6312.     finally
  6313.       if pVChkDesc <> nil then FreeMem(pVChkDesc, iValChkCount * SizeOf(VCHKDesc));
  6314.       if pIdxDesc <> nil then FreeMem(pIdxDesc, iIdxCount * SizeOf(IDXDesc));
  6315.       if pFldDesc <> nil then FreeMem(pFldDesc, iFldCount * SizeOf(FLDDesc));
  6316.       if FieldDescs <> nil then FreeMem(FieldDescs, iFldCount * SizeOf(FLDDesc));
  6317.       SetDBFlag(dbfTable, False);
  6318.     end;
  6319.   end;
  6320. end;
  6321.  
  6322. procedure TTable.DeleteTable;
  6323. var
  6324.   STableName: array[0..DBIMAXTBLNAMELEN - 1] of Char;
  6325. begin
  6326.   CheckInactive;
  6327.   SetDBFlag(dbfTable, True);
  6328.   try
  6329.     Check(DbiDeleteTable(DBHandle, AnsiToNative(DBLocale, TableName,
  6330.       STableName, SizeOf(STableName) - 1), GetTableTypeName));
  6331.   finally
  6332.     SetDBFlag(dbfTable, False);
  6333.   end;
  6334. end;
  6335.  
  6336. procedure TTable.EmptyTable;
  6337. var
  6338.   STableName: array[0..DBIMAXTBLNAMELEN - 1] of Char;
  6339. begin
  6340.   if Active then
  6341.   begin
  6342.     CheckBrowseMode;
  6343.     Check(DbiEmptyTable(DBHandle, Handle, nil, nil));
  6344.     ClearBuffers;
  6345.     DataEvent(deDataSetChange, 0);
  6346.   end else
  6347.   begin
  6348.     SetDBFlag(dbfTable, True);
  6349.     try
  6350.       Check(DbiEmptyTable(DBHandle, nil, AnsiToNative(DBLocale, TableName,
  6351.         STableName, SizeOf(STableName) - 1), GetTableTypeName));
  6352.     finally
  6353.       SetDBFlag(dbfTable, False);
  6354.     end;
  6355.   end;
  6356. end;
  6357.  
  6358. procedure TTable.LockTable(LockType: TLockType);
  6359. begin
  6360.   SetTableLock(LockType, True);
  6361. end;
  6362.  
  6363. procedure TTable.SetTableLock(LockType: TLockType; Lock: Boolean);
  6364. var
  6365.   L: DBILockType;
  6366. begin
  6367.   CheckActive;
  6368.   if LockType = ltReadLock then L := dbiREADLOCK else L := dbiWRITELOCK;
  6369.   if Lock then
  6370.     Check(DbiAcqTableLock(Handle, L)) else
  6371.     Check(DbiRelTableLock(Handle, False, L));
  6372. end;
  6373.  
  6374. procedure TTable.UnlockTable(LockType: TLockType);
  6375. begin
  6376.   SetTableLock(LockType, False);
  6377. end;
  6378.  
  6379. procedure TTable.RenameTable(const NewTableName: string);
  6380. var
  6381.   SCurTableName: array[0..DBIMAXTBLNAMELEN - 1] of Char;
  6382.   SNewTableName: array[0..DBIMAXTBLNAMELEN - 1] of Char;
  6383. begin
  6384.   CheckInactive;
  6385.   SetDBFlag(dbfTable, True);
  6386.   try
  6387.     Check(DbiRenameTable(DBHandle, AnsiToNative(DBLocale, TableName,
  6388.       SCurTableName, SizeOf(SCurTableName) - 1), GetTableTypeName,
  6389.       AnsiToNative(DBLocale, NewTableName, SNewTableName,
  6390.       SizeOf(SNewTableName) - 1)));
  6391.   finally
  6392.     SetDBFlag(dbfTable, False);
  6393.   end;
  6394.   TableName := NewTableName;
  6395. end;
  6396.  
  6397. procedure TTable.EncodeFieldDesc(var FieldDesc: FLDDesc;
  6398.   const Name: string; DataType: TFieldType; Size: Word);
  6399. begin
  6400.   with FieldDesc do
  6401.   begin
  6402.     AnsiToNative(Locale, Name, szName, SizeOf(szName) - 1);
  6403.     iFldType := FldTypeMap[DataType];
  6404.     iSubType := FldSubTypeMap[DataType];
  6405.     case DataType of
  6406.       ftString, ftBytes, ftVarBytes, ftBlob, ftMemo, ftGraphic,
  6407.       ftFmtMemo, ftParadoxOle, ftDBaseOle, ftTypedBinary:
  6408.         iUnits1 := Size;
  6409.       ftBCD:
  6410.         begin
  6411.           iUnits1 := 32;
  6412.           iUnits2 := Size;
  6413.         end;
  6414.     end;
  6415.   end;
  6416. end;
  6417.  
  6418. procedure TTable.DataEvent(Event: TDataEvent; Info: Longint);
  6419. begin
  6420.   if Event = dePropertyChange then FIndexDefs.Updated := False;
  6421.   inherited DataEvent(Event, Info);
  6422. end;
  6423.  
  6424. { Informational & Property }
  6425.  
  6426. function TTable.GetCanModify: Boolean;
  6427. begin
  6428.   Result := inherited GetCanModify and not ReadOnly;
  6429. end;
  6430.  
  6431. function TTable.GetDriverTypeName(Buffer: PChar): PChar;
  6432. var
  6433.   Length: Word;
  6434. begin
  6435.   Result := Buffer;
  6436.   Check(DbiGetProp(HDBIOBJ(DBHandle), dbDATABASETYPE, Buffer,
  6437.     SizeOf(DBINAME), Length));
  6438.   if StrIComp(Buffer, szCFGDBSTANDARD) = 0 then
  6439.   begin
  6440.     Result := GetTableTypeName;
  6441.     if Result <> nil then Result := StrCopy(Buffer, Result);
  6442.   end;
  6443. end;
  6444.  
  6445. function TTable.GetTableTypeName: PChar;
  6446. const
  6447.  { ! Investigate using nil here for parameter1 to make default driver work. }
  6448.   Names: array[TTableType] of PChar =
  6449.     (szPARADOX, szPARADOX, szDBASE, szASCII);
  6450. var
  6451.   TableType: TTableType;
  6452.   Extension: string;
  6453. begin
  6454.   Result := nil;
  6455.   if not Database.IsSQLBased then
  6456.   begin
  6457.     TableType := FTableType;
  6458.     if TableType = ttDefault then
  6459.     begin
  6460.       Extension := ExtractFileExt(FTableName);
  6461.       if CompareText(Extension, '.DBF') = 0 then TableType := ttDBase;
  6462.       if CompareText(Extension, '.TXT') = 0 then TableType := ttASCII;
  6463.     end;
  6464.     Result := Names[TableType];
  6465.   end;
  6466. end;
  6467.  
  6468. function TTable.GetTableLevel: Integer;
  6469. begin
  6470.   if Handle <> nil then
  6471.     Result := GetIntProp(Handle, curTABLELEVEL) else
  6472.     Result := FTableLevel;
  6473. end;
  6474.  
  6475. function TTable.IsDBaseTable: Boolean;
  6476. begin
  6477.   Result := (FTableType = ttDBase) or
  6478.     (CompareText(ExtractFileExt(TableName), '.DBF') = 0);
  6479. end;
  6480.  
  6481. procedure TTable.SetExclusive(Value: Boolean);
  6482. begin
  6483.   CheckInactive;
  6484.   FExclusive := Value;
  6485. end;
  6486.  
  6487. procedure TTable.SetReadOnly(Value: Boolean);
  6488. begin
  6489.   CheckInactive;
  6490.   FReadOnly := Value;
  6491. end;
  6492.  
  6493. procedure TTable.SetTableName(const Value: TFileName);
  6494. begin
  6495.   CheckInactive;
  6496.   if not (csReading in ComponentState) and
  6497.     (FTableName <> Value) then IndexFiles.Clear;
  6498.   FTableName := Value;
  6499.   DataEvent(dePropertyChange, 0);
  6500. end;
  6501.  
  6502. procedure TTable.SetTableType(Value: TTableType);
  6503. begin
  6504.   CheckInactive;
  6505.   FTableType := Value;
  6506. end;
  6507.  
  6508. { TParams }
  6509.  
  6510. constructor TParams.Create;
  6511. begin
  6512.   FItems := TList.Create;
  6513. end;
  6514.  
  6515. destructor TParams.Destroy;
  6516. begin
  6517.   Clear;
  6518.   FItems.Free;
  6519.   inherited Destroy;
  6520. end;
  6521.  
  6522. procedure TParams.Assign(Source: TPersistent);
  6523. var
  6524.   I: Integer;
  6525. begin
  6526.   if Source is TParams then
  6527.   begin
  6528.     Clear;
  6529.     for I := 0 to TParams(Source).Count - 1 do
  6530.       with TParam.Create(Self, ptUnknown) do
  6531.         Assign(TParams(Source)[I]);
  6532.   end
  6533.   else inherited Assign(Source);
  6534. end;
  6535.  
  6536. procedure TParams.AssignTo(Dest: TPersistent);
  6537. begin
  6538.   if Dest is TParams then TParams(Dest).Assign(Self)
  6539.   else inherited AssignTo(Dest);
  6540. end;
  6541.  
  6542. procedure TParams.AssignValues(Value: TParams);
  6543. var
  6544.   I, J: Integer;
  6545. begin
  6546.   for I := 0 to Count - 1 do
  6547.     for J := 0 to Value.Count - 1 do
  6548.       if Items[I].Name = Value[J].Name then
  6549.       begin
  6550.         Items[I].Assign(Value[J]);
  6551.         Break;
  6552.       end;
  6553. end;
  6554.  
  6555. procedure TParams.AddParam(Value: TParam);
  6556. begin
  6557.   FItems.Add(Value);
  6558.   Value.FParamList := Self;
  6559. end;
  6560.  
  6561. procedure TParams.RemoveParam(Value: TParam);
  6562. begin
  6563.   FItems.Remove(Value);
  6564.   Value.FParamList := nil;
  6565. end;
  6566.  
  6567. function TParams.CreateParam(FldType: TFieldType; const ParamName: string;
  6568.   ParamType: TParamType): TParam;
  6569. begin
  6570.   Result := TParam.Create(Self, ParamType);
  6571.   with Result do
  6572.   begin
  6573.     Name := ParamName;
  6574.     DataType :=  FldType;
  6575.   end;
  6576. end;
  6577.  
  6578. function TParams.Count: Integer;
  6579. begin
  6580.   Result := FItems.Count;
  6581. end;
  6582.  
  6583. function TParams.IsEqual(Value: TParams): Boolean;
  6584. var
  6585.   I: Integer;
  6586. begin
  6587.   Result := Count = Value.Count;
  6588.   if Result then
  6589.     for I := 0 to Count - 1 do
  6590.     begin
  6591.       Result := Items[I].IsEqual(Value.Items[I]);
  6592.       if not Result then Break;
  6593.     end
  6594. end;
  6595.  
  6596. procedure TParams.Clear;
  6597. begin
  6598.   while FItems.Count > 0 do TParam(FItems.Last).Free;
  6599. end;
  6600.  
  6601. function TParams.GetParam(Index: Word): TParam;
  6602. begin
  6603.   Result := ParamByName(TParam(FItems[Index]).Name);
  6604. end;
  6605.  
  6606. function TParams.ParamByName(const Value: string): TParam;
  6607. var
  6608.   I: Integer;
  6609. begin
  6610.   for I := 0 to FItems.Count - 1 do
  6611.   begin
  6612.     Result := FItems[I];
  6613.     if AnsiCompareText(Result.Name, Value) = 0 then Exit;
  6614.   end;
  6615.   DatabaseErrorFmt(SParameterNotFound, [Value]);
  6616.   Result := nil;
  6617. end;
  6618.  
  6619. procedure TParams.DefineProperties(Filer: TFiler);
  6620. begin
  6621.   inherited DefineProperties(Filer);
  6622.   Filer.DefineBinaryProperty('Data', ReadBinaryData, WriteBinaryData, Count > 0);
  6623. end;
  6624.  
  6625. procedure TParams.ReadBinaryData(Stream: TStream);
  6626. var
  6627.   I, Temp, NumItems: Integer;
  6628.   Buffer: array[0..2047] of Char;
  6629.   TempStr: string;
  6630.   Version: Word;
  6631. begin
  6632.   Clear;
  6633.   with Stream do
  6634.   begin
  6635.     ReadBuffer(Version, SizeOf(Version));
  6636.     if Version > 2 then DatabaseError(SInvalidVersion);
  6637.     NumItems := 0;
  6638.     if Version = 2 then
  6639.       ReadBuffer(NumItems, SizeOf(NumItems)) else
  6640.       ReadBuffer(NumItems, 2);
  6641.     for I := 0 to NumItems - 1 do
  6642.       with TParam.Create(Self, ptUnknown) do
  6643.       begin
  6644.         Temp := 0;
  6645.         if Version = 2 then
  6646.           ReadBuffer(Temp, SizeOf(Temp)) else
  6647.           ReadBuffer(Temp, 1);
  6648.         SetLength(TempStr, Temp);
  6649.         ReadBuffer(PChar(TempStr)^, Temp);
  6650.         Name := TempStr;
  6651.         ReadBuffer(FParamType, SizeOf(FParamType));
  6652.         ReadBuffer(FDataType, SizeOf(FDataType));
  6653.         if DataType <> ftUnknown then
  6654.         begin
  6655.           Temp := 0;
  6656.           if Version = 2 then
  6657.             ReadBuffer(Temp, SizeOf(Temp)) else
  6658.             ReadBuffer(Temp, 2);
  6659.           ReadBuffer(Buffer, Temp);
  6660.           if DataType in [ftBlob, ftGraphic..ftDBaseOLE] then
  6661.             SetBlobData(@Buffer, Temp) else
  6662.             SetData(@Buffer);
  6663.         end;
  6664.         ReadBuffer(FNull, SizeOf(FNull));
  6665.         ReadBuffer(FBound, SizeOf(FBound));
  6666.       end;
  6667.   end;
  6668. end;
  6669.  
  6670. procedure TParams.WriteBinaryData(Stream: TStream);
  6671. var
  6672.   I: Integer;
  6673.   Temp: SmallInt;
  6674.   Version: Word;
  6675.   Buffer: array[0..2047] of Char;
  6676. begin
  6677.   with Stream do
  6678.   begin
  6679.     Version := GetVersion;
  6680.     WriteBuffer(Version, SizeOf(Version));
  6681.     Temp := Count;
  6682.     WriteBuffer(Temp, SizeOf(Temp));
  6683.     for I := 0 to Count - 1 do
  6684.       with Items[I] do
  6685.       begin
  6686.         Temp := Length(FName);
  6687.         WriteBuffer(Temp, 1);
  6688.         WriteBuffer(PChar(FName)^, Length(FName));
  6689.         WriteBuffer(FParamType, SizeOf(FParamType));
  6690.         WriteBuffer(FDataType, SizeOf(FDataType));
  6691.         if (DataType <> ftUnknown) then
  6692.         begin
  6693.           if GetDataSize > SizeOf(Buffer) then
  6694.             DatabaseErrorFmt(SParamTooBig, [Name, SizeOf(Buffer)]);
  6695.           Temp := GetDataSize;
  6696.           GetData(@Buffer);
  6697.           WriteBuffer(Temp, SizeOf(Temp));
  6698.           WriteBuffer(Buffer, Temp);
  6699.         end;
  6700.         WriteBuffer(FNull, SizeOf(FNull));
  6701.         WriteBuffer(FBound, SizeOf(FBound));
  6702.       end;
  6703.   end;
  6704. end;
  6705.  
  6706. function TParams.GetVersion: Word;
  6707. begin
  6708.   Result := 1;
  6709. end;
  6710.  
  6711. function TParams.GetParamValue(const ParamName: string): Variant;
  6712. var
  6713.   I: Integer;
  6714.   Params: TList;
  6715. begin
  6716.   if Pos(';', ParamName) <> 0 then
  6717.   begin
  6718.     Params := TList.Create;
  6719.     try
  6720.       GetParamList(Params, ParamName);
  6721.       Result := VarArrayCreate([0, Params.Count - 1], varVariant);
  6722.       for I := 0 to Params.Count - 1 do
  6723.         Result[I] := TParam(Params[I]).Value;
  6724.     finally
  6725.       Params.Free;
  6726.     end;
  6727.   end else
  6728.     Result := ParamByName(ParamName).Value
  6729. end;
  6730.  
  6731. procedure TParams.SetParamValue(const ParamName: string;
  6732.   const Value: Variant);
  6733. var
  6734.   I: Integer;
  6735.   Params: TList;
  6736. begin
  6737.   if Pos(';', ParamName) <> 0 then
  6738.   begin
  6739.     Params := TList.Create;
  6740.     try
  6741.       GetParamList(Params, ParamName);
  6742.       for I := 0 to Params.Count - 1 do
  6743.         TParam(Params[I]).Value := Value[I];
  6744.     finally
  6745.       Params.Free;
  6746.     end;
  6747.   end else
  6748.     ParamByName(ParamName).Value := Value;
  6749. end;
  6750.  
  6751. procedure TParams.GetParamList(List: TList; const ParamNames: string);
  6752. var
  6753.   Pos: Integer;
  6754. begin
  6755.   Pos := 1;
  6756.   while Pos <= Length(ParamNames) do
  6757.     List.Add(ParamByName(ExtractFieldName(ParamNames, Pos)));
  6758. end;
  6759.  
  6760. { TParam }
  6761.  
  6762. constructor TParam.Create(AParamList: TParams; AParamType: TParamType);
  6763. begin
  6764.   if AParamList <> nil then AParamList.AddParam(Self);
  6765.   ParamType := AParamType;
  6766.   DataType := ftUnknown;
  6767.   FBound := False;
  6768. end;
  6769.  
  6770. destructor TParam.Destroy;
  6771. begin
  6772.   if FParamList <> nil then FParamList.RemoveParam(Self);
  6773. end;
  6774.  
  6775. function TParam.IsEqual(Value: TParam): Boolean;
  6776. begin
  6777.   Result := (VarType(FData) = VarType(Value.FData)) and
  6778.     (FData = Value.FData) and (Name = Value.Name) and
  6779.     (DataType = Value.DataType) and (IsNull = Value.IsNull) and
  6780.     (Bound = Value.Bound) and (ParamType = Value.ParamType);
  6781. end;
  6782.  
  6783. procedure TParam.SetDataType(Value: TFieldType);
  6784. begin
  6785.   FData := 0;
  6786.   FDataType := Value;
  6787. end;
  6788.  
  6789. function TParam.GetDataSize: Integer;
  6790. begin
  6791.   case DataType of
  6792.     ftString, ftMemo: Result := Length(FData) + 1;
  6793.     ftBoolean: Result := SizeOf(WordBool);
  6794.     ftBCD: Result := SizeOf(FMTBcd);
  6795.     ftDateTime,
  6796.     ftCurrency,
  6797.     ftFloat: Result := SizeOf(Double);
  6798.     ftTime,
  6799.     ftDate,
  6800.     ftAutoInc,
  6801.     ftInteger: Result := SizeOf(Integer);
  6802.     ftSmallint: Result := SizeOf(SmallInt);
  6803.     ftWord: Result := SizeOf(Word);
  6804.     ftBlob, ftGraphic..ftDBaseOLE: Result := Length(FData);
  6805.     ftCursor: Result := 0;
  6806.   else
  6807.     if DataType = ftUnknown then
  6808.       DatabaseErrorFmt(SFieldUndefinedType, [Name]) else
  6809.       DatabaseErrorFmt(SFieldUnsupportedType, [Name]);
  6810.     Result := 0;
  6811.   end;
  6812. end;
  6813.  
  6814. function TParam.RecBufDataSize: Integer;
  6815. begin
  6816.   if ((DataType = ftString) and (Length(FData) > 255)) or
  6817.      (DataType in [ftBlob..ftDBaseOLE]) then
  6818.     Result := SizeOf(BlobParamDesc) else
  6819.     Result := GetDataSize;
  6820. end;
  6821.  
  6822. procedure TParam.RecBufGetData(Buffer: Pointer; Locale: TLocale);
  6823.  
  6824.   function GetNativeStr: string;
  6825.   begin
  6826.     if Locale <> nil then
  6827.     begin
  6828.       SetLength(FNativeStr, Length(FData));
  6829.       AnsiToNativeBuf(Locale, PChar(string(FData)),
  6830.         PChar(string(FNativeStr)), Length(FData));
  6831.       Result := FNativeStr;
  6832.     end else
  6833.       Result := FData;
  6834.   end;
  6835.  
  6836. begin
  6837.   if (DataType = ftString) or (DataType = ftMemo)  then
  6838.   begin
  6839.     if (Length(FData) > 255) or (DataType = ftMemo) then
  6840.     begin
  6841.       BlobParamDesc(Buffer^).ulBlobLen := Length(FData);
  6842.       BlobParamDesc(Buffer^).pBlobBuffer := PChar(GetNativeStr);
  6843.     end else
  6844.     begin
  6845.       if (Locale <> nil) then
  6846.         AnsiToNativeBuf(Locale, PChar(string(FData)), Buffer, Length(FData) + 1) else
  6847.         GetData(Buffer);
  6848.     end;
  6849.   end
  6850.   else if (DataType in [ftBlob..ftDBaseOLE]) then
  6851.   begin
  6852.     with BlobParamDesc(Buffer^) do
  6853.     begin
  6854.       ulBlobLen := Length(FData);
  6855.       pBlobBuffer := PChar(string(FData));
  6856.     end;
  6857.   end else
  6858.     GetData(Buffer);
  6859. end;
  6860.  
  6861. procedure TParam.GetData(Buffer: Pointer);
  6862. begin
  6863.   case DataType of
  6864.     ftUnknown: DatabaseErrorFmt(SFieldUndefinedType, [Name]);
  6865.     ftString, ftMemo: StrMove(Buffer, PChar(string(FData)), Length(FData) + 1);
  6866.     ftSmallint: SmallInt(Buffer^) := FData;
  6867.     ftWord: Word(Buffer^) := FData;
  6868.     ftAutoInc,
  6869.     ftInteger: Integer(Buffer^) := FData;
  6870.     ftTime: Integer(Buffer^) := DateTimeToTimeStamp(AsDateTime).Time;
  6871.     ftDate: Integer(Buffer^) := DateTimeToTimeStamp(AsDateTime).Date;
  6872.     ftDateTime:  Double(Buffer^) := TimeStampToMSecs(DateTimeToTimeStamp(AsDateTime));
  6873.     ftBCD: CurrToFMTBCD(AsBCD, FMTBcd(Buffer^), 32, 4);
  6874.     ftCurrency,
  6875.     ftFloat: Double(Buffer^) := FData;
  6876.     ftBoolean: WordBool(Buffer^) := FData;
  6877.     ftBlob, ftGraphic..ftTypedBinary: Move(PChar(string(FData))^, Buffer^, Length(FData));
  6878.     ftCursor: {Nothing};
  6879.   else
  6880.     DatabaseErrorFmt(SFieldUnsupportedType, [Name]);
  6881.   end;
  6882. end;
  6883.  
  6884. procedure TParam.SetBlobData(Buffer: Pointer; Size: Integer);
  6885. var
  6886.   DataStr: string;
  6887. begin
  6888.   SetLength(DataStr, Size);
  6889.   Move(Buffer^, PChar(DataStr)^, Size);
  6890.   AsBlob := DataStr;
  6891. end;
  6892.  
  6893. procedure TParam.SetData(Buffer: Pointer);
  6894. var
  6895.   Value: Currency;
  6896.   TimeStamp: TTimeStamp;
  6897. begin
  6898.   case DataType of
  6899.     ftUnknown: DatabaseErrorFmt(SFieldUndefinedType, [Name]);
  6900.     ftString: AsString := StrPas(Buffer);
  6901.     ftWord: AsWord := Word(Buffer^);
  6902.     ftSmallint: AsSmallInt := Smallint(Buffer^);
  6903.     ftInteger: AsInteger := Integer(Buffer^);
  6904.     ftTime:
  6905.       begin
  6906.         TimeStamp.Time := LongInt(Buffer^);
  6907.         TimeStamp.Date := DateDelta;
  6908.         AsTime := TimeStampToDateTime(TimeStamp);
  6909.       end;
  6910.     ftDate:
  6911.       begin
  6912.         TimeStamp.Time := 0;
  6913.         TimeStamp.Date := Integer(Buffer^);
  6914.         AsDate := TimeStampToDateTime(TimeStamp);
  6915.       end;
  6916.     ftDateTime:
  6917.       begin
  6918.         TimeStamp.Time := 0;
  6919.         TimeStamp.Date := Integer(Buffer^);
  6920.         AsDateTime := TimeStampToDateTime(MSecsToTimeStamp(Double(Buffer^)));
  6921.       end;
  6922.     ftBCD:
  6923.       begin
  6924.         FMTBCDToCurr(FMTBcd(Buffer^), Value);
  6925.         AsBCD := Value;
  6926.       end;
  6927.     ftCurrency: AsCurrency := Double(Buffer^);
  6928.     ftFloat: AsFloat := Double(Buffer^);
  6929.     ftBoolean: AsBoolean := WordBool(Buffer^);
  6930.     ftMemo: AsMemo := StrPas(Buffer);
  6931.     ftCursor: FData := 0;
  6932.   else
  6933.     DatabaseErrorFmt(SFieldUnsupportedType, [Name]);
  6934.   end;
  6935. end;
  6936.  
  6937. procedure TParam.SetText(const Value: string);
  6938. begin
  6939.   InitValue;
  6940.   if DataType = ftUnknown then DataType := ftString;
  6941.   FData := Value;
  6942.   case DataType of
  6943.     ftDateTime, ftTime, ftDate: FData := VarToDateTime(FData);
  6944.     ftBCD: FData := Currency(FData);
  6945.     ftCurrency, ftFloat: FData := Single(FData);
  6946.     ftInteger, ftSmallInt, ftWord: FData := Integer(FData);
  6947.     ftBoolean: FData := Boolean(FData);
  6948.   end;
  6949. end;
  6950.  
  6951. procedure TParam.Assign(Source: TPersistent);
  6952. begin
  6953.   if Source is TParam then
  6954.     AssignParam(TParam(Source))
  6955.   else if Source is TField then
  6956.     AssignField(TField(Source))
  6957.   else
  6958.     inherited Assign(Source);
  6959. end;
  6960.  
  6961. procedure TParam.AssignTo(Dest: TPersistent);
  6962. begin
  6963.   if Dest is TField then
  6964.     TField(Dest).Value := FData
  6965.   else
  6966.     inherited AssignTo(Dest);
  6967. end;
  6968.  
  6969. procedure TParam.AssignParam(Param: TParam);
  6970. begin
  6971.   if Param <> nil then
  6972.   begin
  6973.     DataType := Param.DataType;
  6974.     if Param.IsNull then Clear
  6975.     else begin
  6976.       InitValue;
  6977.       FData := Param.FData;
  6978.     end;
  6979.     FBound := Param.Bound;
  6980.     Name := Param.Name;
  6981.     if ParamType = ptUnknown then ParamType := Param.ParamType;
  6982.   end;
  6983. end;
  6984.  
  6985. procedure TParam.AssignFieldValue(Field: TField; const Value: Variant);
  6986. begin
  6987.   if Field <> nil then
  6988.   begin
  6989.     if (Field.DataType = ftMemo) and (Field.Size > 255) then
  6990.       DataType := ftString else
  6991.       DataType := Field.DataType;
  6992.     if VarIsNull(Value) then Clear
  6993.     else begin
  6994.       InitValue;
  6995.       FData := Value;
  6996.     end;
  6997.     FBound := True;
  6998.   end;
  6999. end;
  7000.  
  7001. procedure TParam.AssignField(Field: TField);
  7002. begin
  7003.   if Field <> nil then
  7004.   begin
  7005.     if (Field.DataType = ftMemo) and (Field.Size > 255) then
  7006.       DataType := ftString else
  7007.       DataType := Field.DataType;
  7008.     if Field.IsNull then Clear
  7009.     else begin
  7010.       InitValue;
  7011.       FData := Field.Value;
  7012.     end;
  7013.     FBound := True;
  7014.     Name := Field.FieldName;
  7015.   end;
  7016. end;
  7017.  
  7018. procedure TParam.Clear;
  7019. begin
  7020.   FNull := True;
  7021.   FData := 0;
  7022. end;
  7023.  
  7024. procedure TParam.InitValue;
  7025. begin
  7026.   FBound := True;
  7027.   FNull := False;
  7028. end;
  7029.  
  7030. procedure TParam.SetAsBoolean(Value: Boolean);
  7031. begin
  7032.   InitValue;
  7033.   DataType := ftBoolean;
  7034.   FData := Value;
  7035. end;
  7036.  
  7037. function TParam.GetAsBoolean: Boolean;
  7038. begin
  7039.   Result := FData;
  7040. end;
  7041.  
  7042. procedure TParam.SetAsFloat(Value: Double);
  7043. begin
  7044.   InitValue;
  7045.   DataType := ftFloat;
  7046.   FData := Value;
  7047. end;
  7048.  
  7049. function TParam.GetAsFloat: Double;
  7050. begin
  7051.   Result := FData;
  7052. end;
  7053.  
  7054. procedure TParam.SetAsCurrency(Value: Double);
  7055. begin
  7056.   SetAsFloat(Value);
  7057.   FDataType := ftCurrency;
  7058. end;
  7059.  
  7060. procedure TParam.SetAsBCD(Value: Currency);
  7061. begin
  7062.   InitValue;
  7063.   FData := Value;
  7064.   FDataType := ftBCD;
  7065. end;
  7066.  
  7067. function TParam.GetAsBCD: Currency;
  7068. begin
  7069.   Result := FData;
  7070. end;
  7071.  
  7072. procedure TParam.SetAsInteger(Value: Longint);
  7073. begin
  7074.   InitValue;
  7075.   DataType := ftInteger;
  7076.   FData := Value;
  7077. end;
  7078.  
  7079. function TParam.GetAsInteger: Longint;
  7080. begin
  7081.   Result := FData;
  7082. end;
  7083.  
  7084. procedure TParam.SetAsWord(Value: LongInt);
  7085. begin
  7086.   SetAsInteger(Value);
  7087.   FDataType := ftWord;
  7088. end;
  7089.  
  7090. procedure TParam.SetAsSmallInt(Value: LongInt);
  7091. begin
  7092.   SetAsInteger(Value);
  7093.   FDataType := ftSmallint;
  7094. end;
  7095.  
  7096. procedure TParam.SetAsString(const Value: string);
  7097. begin
  7098.   InitValue;
  7099.   DataType := ftString;
  7100.   FData := Value;
  7101. end;
  7102.  
  7103. function TParam.GetAsString: string;
  7104. begin
  7105.   if not IsNull then
  7106.     case DataType of
  7107.       ftBoolean:
  7108.         if FData then Result := STextTrue
  7109.         else Result := STextFalse;
  7110.       ftDateTime, ftDate, ftTime: Result := VarFromDateTime(FData)
  7111.       else Result := FData;
  7112.     end
  7113.   else Result := ''
  7114. end;
  7115.  
  7116. procedure TParam.SetAsMemo(const Value: string);
  7117. begin
  7118.   InitValue;
  7119.   DataType := ftMemo;
  7120.   FData := Value;
  7121. end;
  7122.  
  7123. function TParam.GetAsMemo: string;
  7124. begin
  7125.   Result := FData;
  7126. end;
  7127.  
  7128. procedure TParam.SetAsBlob(Value: TBlobData);
  7129. begin
  7130.   InitValue;
  7131.   DataType := ftBlob;
  7132.   FData := Value;
  7133. end;
  7134.  
  7135. procedure TParam.SetAsDate(Value: TDateTime);
  7136. begin
  7137.   InitValue;
  7138.   DataType := ftDate;
  7139.   FData := VarFromDateTime(Value);
  7140. end;
  7141.  
  7142. procedure TParam.SetAsTime(Value: TDateTime);
  7143. begin
  7144.   SetAsDate(Value);
  7145.   FDataType := ftTime;
  7146. end;
  7147.  
  7148. procedure TParam.SetAsDateTime(Value: TDateTime);
  7149. begin
  7150.   SetAsDate(Value);
  7151.   FDataType := ftDateTime;
  7152. end;
  7153.  
  7154. function TParam.GetAsDateTime: TDateTime;
  7155. begin
  7156.   if IsNull then
  7157.     Result := 0 else
  7158.     Result := VarToDateTime(FData);
  7159. end;
  7160.  
  7161. procedure TParam.SetAsVariant(Value: Variant);
  7162. begin
  7163.   InitValue;
  7164.   case VarType(Value) of
  7165.     varSmallint: DataType := ftSmallInt;
  7166.     varInteger: DataType := ftInteger;
  7167.     varCurrency: DataType := ftBCD;
  7168.     varSingle,
  7169.     varDouble: DataType := ftFloat;
  7170.     varDate: DataType := ftDateTime;
  7171.     varBoolean: DataType := ftBoolean;
  7172.     varString: DataType := ftString;
  7173.     else DataType := ftUnknown;
  7174.   end;
  7175.   FData := Value;
  7176. end;
  7177.  
  7178. function TParam.GetAsVariant: Variant;
  7179. begin
  7180.   Result := FData;
  7181. end;
  7182.  
  7183. { TQueryDataLink }
  7184.  
  7185. constructor TQueryDataLink.Create(AQuery: TQuery);
  7186. begin
  7187.   inherited Create;
  7188.   FQuery := AQuery;
  7189. end;
  7190.  
  7191. procedure TQueryDataLink.ActiveChanged;
  7192. begin
  7193.   if FQuery.Active then FQuery.RefreshParams;
  7194. end;
  7195.  
  7196. procedure TQueryDataLink.RecordChanged(Field: TField);
  7197. begin
  7198.   if (Field = nil) and FQuery.Active then FQuery.RefreshParams;
  7199. end;
  7200.  
  7201. procedure TQueryDataLink.CheckBrowseMode;
  7202. begin
  7203.   if FQuery.Active then FQuery.CheckBrowseMode;
  7204. end;
  7205.  
  7206. { TStoredProc }
  7207.  
  7208. constructor TStoredProc.Create(AOwner: TComponent);
  7209. begin
  7210.   inherited Create(AOwner);
  7211.   FParams := TParams.Create;
  7212.   FParamDesc := nil;
  7213.   FRecordBuffer := nil;
  7214.   FServerDescs := nil;
  7215. end;
  7216.  
  7217. destructor TStoredProc.Destroy;
  7218. begin
  7219.   Destroying;
  7220.   Disconnect;
  7221.   FParams.Free;
  7222.   inherited Destroy;
  7223. end;
  7224.  
  7225. procedure TStoredProc.Disconnect;
  7226. begin
  7227.   Close;
  7228.   UnPrepare;
  7229. end;
  7230.  
  7231. function TStoredProc.CreateCursor(GenHandle: Boolean): HDBICur;
  7232. begin
  7233.   if StoredProcName <> '' then
  7234.   begin
  7235.     SetPrepared(True);
  7236.     Result := GetCursor(GenHandle);
  7237.   end else
  7238.     Result := nil;
  7239. end;
  7240.  
  7241. function TStoredProc.CreateHandle: HDBICur;
  7242. begin
  7243.   Result := CreateCursor(True);
  7244. end;
  7245.  
  7246. function TStoredProc.GetCursor(GenHandle: Boolean): HDBICur;
  7247. var
  7248.   PCursor: phDBICur;
  7249. begin
  7250.   Result := nil;
  7251.   if GenHandle then PCursor := @Result
  7252.   else PCursor := nil;
  7253.   BindParams;
  7254.   Check(DbiQExec(StmtHandle, PCursor));
  7255.   GetResults;
  7256. end;
  7257.  
  7258. procedure TStoredProc.ExecProc;
  7259. begin
  7260.   CheckInActive;
  7261.   SetDBFlag(dbfExecProc, True);
  7262.   try
  7263.     CreateCursor(False);
  7264.   finally
  7265.     SetDBFlag(dbfExecProc, False);
  7266.   end;
  7267. end;
  7268.  
  7269. procedure TStoredProc.SetProcName(const Value: string);
  7270. begin
  7271.   if not (csReading in ComponentState) then
  7272.   begin
  7273.     CheckInactive;
  7274.     if Value <> FProcName then
  7275.     begin
  7276.       FProcName := Value;
  7277.       FreeStatement;
  7278.       FParams.Clear;
  7279.     end;
  7280.   end else
  7281.     FProcName := Value;
  7282. end;
  7283.  
  7284. procedure TStoredProc.SetOverLoad(Value: Word);
  7285. begin
  7286.   if not (csReading in ComponentState) then
  7287.   begin
  7288.     CheckInactive;
  7289.     if Value <> OverLoad then
  7290.     begin
  7291.       FOverLoad := Value;
  7292.       FreeStatement;
  7293.       FParams.Clear;
  7294.     end
  7295.   end else
  7296.     FOverLoad := Value;
  7297. end;
  7298.  
  7299. function TStoredProc.GetParamsCount: Word;
  7300. begin
  7301.   Result := FParams.Count;
  7302. end;
  7303.  
  7304. procedure TStoredProc.CreateParamDesc;
  7305. var
  7306.   Desc: SPParamDesc;
  7307.   Cursor: HDBICur;
  7308.   Buffer: array[0..DBIMAXSPNAMELEN] of Char;
  7309.   Name: string;
  7310.   DataType: TFieldType;
  7311. begin
  7312.   AnsiToNative(DBLocale, StoredProcName, Buffer, DBIMAXSPNAMELEN);
  7313.   if DbiOpenSPParamList(DBHandle, Buffer, False, OverLoad, Cursor) = 0 then
  7314.   try
  7315.     while DbiGetNextRecord(Cursor, dbiNOLOCK, @Desc, nil) = 0 do
  7316.       with Desc do
  7317.       begin
  7318.         NativeToAnsi(DBLocale, szName, Name);
  7319.         if (TParamType(eParamType) = ptResult) and (Name = '') then
  7320.           Name := SResultName;
  7321.         if uFldType < MAXLOGFLDTYPES then DataType := DataTypeMap[uFldType]
  7322.         else DataType := ftUnknown;
  7323.         if (uFldType = fldFLOAT) and (uSubType = fldstMONEY) then
  7324.           DataType := ftCurrency;
  7325.         FParams.CreateParam(DataType, Name, TParamType(eParamType));
  7326.       end;
  7327.     SetServerParams;
  7328.   finally
  7329.     DbiCloseCursor(Cursor);
  7330.   end;
  7331. end;
  7332.  
  7333. procedure TStoredProc.SetServerParams;
  7334. var
  7335.   I: Integer;
  7336.   DescPtr: PServerDesc;
  7337. begin
  7338.   FServerDescs := StrAlloc(Params.Count * SizeOf(TServerDesc));
  7339.   DescPtr := PServerDesc(FServerDescs);
  7340.   for I := 0 to Params.Count - 1 do
  7341.     with Params[I], DescPtr^ do
  7342.     begin
  7343.       ParamName := Name;
  7344.       BindType := DataType;
  7345.       Inc(DescPtr);
  7346.     end;
  7347. end;
  7348.  
  7349. function TStoredProc.CheckServerParams: Boolean;
  7350. var
  7351.   I, J: Integer;
  7352.   DescPtr: PServerDesc;
  7353. begin
  7354.   if FServerDescs = nil then
  7355.   begin
  7356.     SetServerParams;
  7357.     Result := False;
  7358.   end else
  7359.   begin
  7360.     DescPtr := PServerDesc(FServerDescs);
  7361.     for I := 0 to StrBufSize(FServerDescs) div SizeOf(TServerDesc) - 1 do
  7362.     begin
  7363.       for J := 0 to Params.Count - 1 do
  7364.         with Params.Items[J], DescPtr^ do
  7365.           if (Name = ParamName) and (DataType <> BindType) then
  7366.           begin
  7367.             Result := False;
  7368.             Exit;
  7369.           end;
  7370.       Inc(DescPtr);
  7371.     end;
  7372.     Result := True;
  7373.   end;
  7374. end;
  7375.  
  7376. function TStoredProc.DescriptionsAvailable: Boolean;
  7377. var
  7378.   Cursor: HDBICur;
  7379.   Buffer: array[0..DBIMAXSPNAMELEN] of Char;
  7380. begin
  7381.   SetDBFlag(dbfProcDesc, True);
  7382.   try
  7383.     AnsiToNative(DBLocale, StoredProcName, Buffer, DBIMAXSPNAMELEN);
  7384.     Result := DbiOpenSPParamList(DBHandle, Buffer, False, OverLoad, Cursor) = 0;
  7385.     if Result then DbiCloseCursor(Cursor);
  7386.   finally
  7387.     SetDBFlag(dbfProcDesc, False);
  7388.   end;
  7389. end;
  7390.  
  7391. procedure TStoredProc.PrepareProc;
  7392. var
  7393.   I: Integer;
  7394.   ParamDescs: PSPParamDescList;
  7395.   NumBytes, Offset: Word;
  7396.   Buffer: array[0..DBIMAXSPNAMELEN] of Char;
  7397. begin
  7398.   FParamDesc := StrAlloc(FParams.Count * SizeOf(SPParamDesc));
  7399.   FillChar(FParamDesc^, StrBufSize(FParamDesc), 0);
  7400.   ParamDescs := PSPParamDescList(FParamDesc);
  7401.   NumBytes := 0;
  7402.   for I := 0 to FParams.Count - 1 do
  7403.     with Params[I] do
  7404.       if DataType = ftString then Inc(NumBytes, 255 + 2)
  7405.       else Inc(NumBytes, RecBufDataSize + 2);
  7406.   FRecordBuffer := StrAlloc(NumBytes);
  7407.   FillChar(FRecordBuffer^, NumBytes, 0);
  7408.   Offset := 0;
  7409.   for I := 0 to FParams.Count - 1 do
  7410.   begin
  7411.     with Params[I], ParamDescs[I] do
  7412.     begin
  7413.       if DataType = ftUnknown then
  7414.         DatabaseErrorFmt(SNoParameterValue, [Name]);
  7415.       if ParamType = ptUnknown then
  7416.         DatabaseErrorFmt(SNoParameterType, [Name]);
  7417.       if FBindMode = pbByName then
  7418.         AnsiToNative(Locale, Name, szName, DBIMAXNAMELEN)
  7419.       else uParamNum := I + 1;
  7420.       eParamType := STMTParamType(ParamType);
  7421.       uFldType := FldTypeMap[DataType];
  7422.       if DataType = ftCurrency then uSubType := fldstMONEY;
  7423.       if uFldType = fldZString then
  7424.       begin
  7425.         uLen := 255;
  7426.         iUnits1 := 255;
  7427.       end else
  7428.         uLen := RecBufDataSize;
  7429.       uOffset := Offset;
  7430.       Inc(Offset, uLen);
  7431.       uNullOffset := NumBytes - 2 * (I + 1);
  7432.       if ParamType in [ptInput, ptInputOutput] then
  7433.         SmallInt(Pointer(FRecordBuffer + NumBytes - 2 * (I + 1))^) := IndNull;
  7434.     end;
  7435.   end;
  7436.   AnsiToNative(Locale, StoredProcName, Buffer, DBIMAXSPNAMELEN);
  7437.   Check(DbiQPrepareProc(DBHandle, Buffer, FParams.Count,
  7438.     PSPParamDesc(FParamDesc), nil, FStmtHandle));
  7439. end;
  7440.  
  7441. procedure TStoredProc.GetResults;
  7442. var
  7443.   I: Integer;
  7444.   CurPtr: PChar;
  7445.   IntPtr: ^SmallInt;
  7446.   NumBytes: Word;
  7447. begin
  7448.   if FRecordBuffer <> nil then
  7449.   begin
  7450.     CurPtr := FRecordBuffer;
  7451.     NumBytes := StrBufSize(FRecordBuffer);
  7452.     for I := 0 to FParams.Count - 1 do
  7453.       with Params[I] do
  7454.       begin
  7455.         if ParamType in [ptOutput, ptInputOutput, ptResult] then
  7456.         begin
  7457.           if DataType = ftString then
  7458.             NativeToAnsiBuf(Locale, CurPtr, CurPtr, StrLen(CurPtr));
  7459.           IntPtr := Pointer(FRecordBuffer + NumBytes - 2 * (I + 1));
  7460.           if IntPtr^ = IndNull then Clear
  7461.           else if IntPtr^ = IndTrunc then DatabaseErrorFmt(STruncationError, [Name])
  7462.           else SetData(CurPtr);
  7463.         end;
  7464.         if DataType = ftString then Inc(CurPtr, 255)
  7465.         else Inc(CurPtr, RecBufDataSize);
  7466.       end;
  7467.   end;
  7468. end;
  7469.  
  7470. procedure TStoredProc.BindParams;
  7471. var
  7472.   I: Integer;
  7473.   CurPtr: PChar;
  7474.   NumBytes: Word;
  7475.   IntPtr: ^SmallInt;
  7476.   DrvName: array[0..DBIMAXNAMELEN - 1] of Char;
  7477.   DrvLocale: TLocale;
  7478. begin
  7479.   if FRecordBuffer = nil then Exit;
  7480.   if not CheckServerParams then
  7481.   begin
  7482.     SetPrepared(False);
  7483.     SetPrepared(True);
  7484.   end;
  7485.   DrvName[0] := #0;
  7486.   DrvLocale := nil;
  7487.   DbiGetProp(HDBIOBJ(StmtHandle), stmtLANGDRVNAME, @DrvName, SizeOf(DrvName), NumBytes);
  7488.   if StrLen(DrvName) > 0 then OsLdLoadBySymbName(DrvName, DrvLocale);
  7489.   try
  7490.     NumBytes := StrBufSize(FRecordBuffer);
  7491.     CurPtr := FRecordBuffer;
  7492.     for I := 0 to FParams.Count - 1 do
  7493.     begin
  7494.       with Params[I] do
  7495.       begin
  7496.         if ParamType in [ptInput, ptInputOutput] then
  7497.         begin
  7498.           RecBufGetData(CurPtr, DrvLocale);
  7499.           IntPtr := Pointer(FRecordBuffer + NumBytes - 2 * (I + 1));
  7500.           if IsNull then IntPtr^ := IndNull
  7501.           else IntPtr^ := 0;
  7502.           if (DataType = ftString) then
  7503.             with PSPParamDescList(FParamDesc)[I] do
  7504.             begin
  7505.               uLen := RecBufDataSize;
  7506.               iUnits1 := Length(FData);
  7507.             end
  7508.         end;
  7509.         if (DataType = ftString) then
  7510.           Inc(CurPtr, 255) else
  7511.           Inc(CurPtr, RecBufDataSize);
  7512.       end;
  7513.     end;
  7514.     Check(DbiQSetProcParams(StmtHandle, FParams.Count,
  7515.       PSPParamDesc(FParamDesc), FRecordBuffer));
  7516.   finally
  7517.     if DrvLocale <> nil then OsLdUnloadObj(DrvLocale);
  7518.   end;
  7519. end;
  7520.  
  7521. procedure TStoredProc.SetPrepared(Value: Boolean);
  7522. begin
  7523.   if Handle <> nil then DatabaseError(SDataSetOpen);
  7524.   if Prepared <> Value then
  7525.   begin
  7526.     if Value then
  7527.       try
  7528.         if FParams.Count = 0 then CreateParamDesc
  7529.         else SetServerParams;
  7530.         if not FQueryMode then PrepareProc;
  7531.         FPrepared := True;
  7532.       except
  7533.         FreeStatement;
  7534.         raise;
  7535.       end
  7536.     else FreeStatement;
  7537.   end;
  7538. end;
  7539.  
  7540. procedure TStoredProc.Prepare;
  7541. begin
  7542.   SetDBFlag(dbfStoredProc, True);
  7543.   SetPrepared(True);
  7544. end;
  7545.  
  7546. procedure TStoredProc.UnPrepare;
  7547. begin
  7548.   SetPrepared(False);
  7549.   SetDBFlag(dbfStoredProc, False);
  7550. end;
  7551.  
  7552. procedure TStoredProc.FreeStatement;
  7553. begin
  7554.   if StmtHandle <> nil then DbiQFree(FStmtHandle);
  7555.   StrDispose(FParamDesc);
  7556.   FParamDesc := nil;
  7557.   StrDispose(FRecordBuffer);
  7558.   FRecordBuffer := nil;
  7559.   StrDispose(FServerDescs);
  7560.   FServerDescs := nil;
  7561.   FPrepared := False;
  7562. end;
  7563.  
  7564. procedure TStoredProc.SetPrepare(Value: Boolean);
  7565. begin
  7566.   if Value then Prepare
  7567.   else UnPrepare;
  7568. end;
  7569.  
  7570. procedure TStoredProc.SetDBFlag(Flag: Integer; Value: Boolean);
  7571. begin
  7572.   if not Value and (DBFlags - [Flag] = []) then SetPrepared(False);
  7573.   inherited SetDBFlag(Flag, Value);
  7574. end;
  7575.  
  7576. procedure TStoredProc.CopyParams(Value: TParams);
  7577. begin
  7578.   if not Prepared and (FParams.Count = 0) then
  7579.   try
  7580.     FQueryMode := True;
  7581.     Prepare;
  7582.     Value.Assign(FParams);
  7583.   finally
  7584.     UnPrepare;
  7585.     FQueryMode := False;
  7586.   end else
  7587.     Value.Assign(FParams);
  7588. end;
  7589.  
  7590. procedure TStoredProc.SetParamsList(Value: TParams);
  7591. begin
  7592.   CheckInactive;
  7593.   if Prepared then
  7594.   begin
  7595.     SetPrepared(False);
  7596.     FParams.Assign(Value);
  7597.     SetPrepared(True);
  7598.   end else
  7599.     FParams.Assign(Value);
  7600. end;
  7601.  
  7602. function TStoredProc.ParamByName(const Value: string): TParam;
  7603. begin
  7604.   Result := FParams.ParamByName(Value);
  7605. end;
  7606.  
  7607. { TQuery }
  7608.  
  7609. constructor TQuery.Create(AOwner: TComponent);
  7610. begin
  7611.   inherited Create(AOwner);
  7612.   FSQL := TStringList.Create;
  7613.   TStringList(SQL).OnChange := QueryChanged;
  7614.   FParams := TParams.Create;
  7615.   FDataLink := TQueryDataLink.Create(Self);
  7616.   RequestLive := False;
  7617.   ParamCheck := True;
  7618.   FRowsAffected := -1;
  7619. end;
  7620.  
  7621. destructor TQuery.Destroy;
  7622. begin
  7623.   Destroying;
  7624.   Disconnect;
  7625.   SQL.Free;
  7626.   FParams.Free;
  7627.   FDataLink.Free;
  7628.   StrDispose(SQLBinary);
  7629.   inherited Destroy;
  7630. end;
  7631.  
  7632. procedure TQuery.Disconnect;
  7633. begin
  7634.   Close;
  7635.   UnPrepare;
  7636. end;
  7637.  
  7638. procedure TQuery.SetPrepare(Value: Boolean);
  7639. begin
  7640.   if Value then Prepare
  7641.   else UnPrepare;
  7642. end;
  7643.  
  7644. procedure TQuery.Prepare;
  7645. begin
  7646.   SetDBFlag(dbfPrepared, True);
  7647.   SetPrepared(True);
  7648. end;
  7649.  
  7650. procedure TQuery.UnPrepare;
  7651. begin
  7652.   SetPrepared(False);
  7653.   SetDBFlag(dbfPrepared, False);
  7654. end;
  7655.  
  7656. procedure TQuery.SetDataSource(Value: TDataSource);
  7657. begin
  7658.   if IsLinkedTo(Value) then DatabaseError(SCircularDataLink);
  7659.   FDataLink.DataSource := Value;
  7660. end;
  7661.  
  7662. function TQuery.GetDataSource: TDataSource;
  7663. begin
  7664.   Result := FDataLink.DataSource;
  7665. end;
  7666.  
  7667. procedure TQuery.SetQuery(Value: TStrings);
  7668. begin
  7669.   if SQL.Text <> Value.Text then
  7670.   begin
  7671.     Disconnect;
  7672.     SQL.BeginUpdate;
  7673.     try
  7674.       SQL.Assign(Value);
  7675.     finally
  7676.       SQL.EndUpdate;
  7677.     end;
  7678.   end;
  7679. end;
  7680.  
  7681. procedure TQuery.QueryChanged(Sender: TObject);
  7682. var
  7683.   List: TParams;
  7684. begin
  7685.   FText := SQL.Text;
  7686.   if not (csLoading in ComponentState) then
  7687.   begin
  7688.     Disconnect;
  7689.     StrDispose(SQLBinary);
  7690.     SQLBinary := nil;
  7691.     if ParamCheck or (csDesigning in ComponentState) then
  7692.     begin
  7693.       List := TParams.Create;
  7694.       try
  7695.         CreateParams(List, PChar(Text));
  7696.         List.AssignValues(FParams);
  7697.         FParams.Free;
  7698.         FParams := List;
  7699.       except
  7700.         List.Free;
  7701.       end;
  7702.     end;
  7703.     DataEvent(dePropertyChange, 0);
  7704.   end else
  7705.     CreateParams(nil, PChar(Text));
  7706. end;
  7707.  
  7708. procedure TQuery.SetParamsList(Value: TParams);
  7709. begin
  7710.   FParams.AssignValues(Value);
  7711. end;
  7712.  
  7713. function TQuery.GetParamsCount: Word;
  7714. begin
  7715.   Result := FParams.Count;
  7716. end;
  7717.  
  7718. procedure TQuery.DefineProperties(Filer: TFiler);
  7719. begin
  7720.   inherited DefineProperties(Filer);
  7721.   Filer.DefineBinaryProperty('Data', ReadBinaryData, WriteBinaryData, SQLBinary <> nil);
  7722. end;
  7723.  
  7724. procedure TQuery.ReadBinaryData(Stream: TStream);
  7725. begin
  7726.   SQLBinary := StrAlloc(Stream.Size);
  7727.   Stream.ReadBuffer(SQLBinary^, Stream.Size);
  7728. end;
  7729.  
  7730. procedure TQuery.WriteBinaryData(Stream: TStream);
  7731. begin
  7732.   Stream.WriteBuffer(SQLBinary^, StrBufSize(SQLBinary));
  7733. end;
  7734.  
  7735. procedure TQuery.SetPrepared(Value: Boolean);
  7736. begin
  7737.   if Handle <> nil then DatabaseError(SDataSetOpen);
  7738.   if Value <> Prepared then
  7739.   begin
  7740.     if Value then
  7741.     begin
  7742.       FRowsAffected := -1;
  7743.       if Length(Text) > 1 then PrepareSQL(PChar(Text))
  7744.       else DatabaseError(SEmptySQLStatement);
  7745.     end
  7746.     else
  7747.     begin
  7748.       FRowsAffected := RowsAffected;
  7749.       FreeStatement;
  7750.     end;
  7751.     FPrepared := Value;
  7752.   end;
  7753. end;
  7754.  
  7755. procedure TQuery.FreeStatement;
  7756. var
  7757.   Result: DbiResult;
  7758. begin
  7759.   if StmtHandle <> nil then
  7760.   begin
  7761.     Result := DbiQFree(FStmtHandle);
  7762.     if not (csDestroying in ComponentState) then
  7763.       Check(Result);
  7764.   end;
  7765. end;
  7766.  
  7767. procedure TQuery.SetParamsFromCursor;
  7768. var
  7769.   I: Integer;
  7770.   DataSet: TDataSet;
  7771. begin
  7772.   if FDataLink.DataSource <> nil then
  7773.   begin
  7774.     DataSet := FDataLink.DataSource.DataSet;
  7775.     if DataSet <> nil then
  7776.     begin
  7777.       DataSet.FieldDefs.Update;
  7778.       for I := 0 to FParams.Count - 1 do
  7779.         with FParams[I] do
  7780.           if not Bound then
  7781.           begin
  7782.             AssignField(DataSet.FieldByName(Name));
  7783.             Bound := False;
  7784.           end;
  7785.     end;
  7786.   end;
  7787. end;
  7788.  
  7789. procedure TQuery.RefreshParams;
  7790. var
  7791.   DataSet: TDataSet;
  7792. begin
  7793.   DisableControls;
  7794.   try
  7795.     if FDataLink.DataSource <> nil then
  7796.     begin
  7797.       DataSet := FDataLink.DataSource.DataSet;
  7798.       if DataSet <> nil then
  7799.         if DataSet.Active and (DataSet.State <> dsSetKey) then
  7800.         begin
  7801.           Close;
  7802.           Open;
  7803.         end;
  7804.     end;
  7805.   finally
  7806.     EnableControls;
  7807.   end;
  7808. end;
  7809.  
  7810. function TQuery.ParamByName(const Value: string): TParam;
  7811. begin
  7812.   Result := FParams.ParamByName(Value);
  7813. end;
  7814.  
  7815. procedure TQuery.CreateParams(List: TParams; const Value: PChar);
  7816. var
  7817.   CurPos, StartPos: PChar;
  7818.   CurChar: Char;
  7819.   Literal: Boolean;
  7820.   EmbeddedLiteral: Boolean;
  7821.   Name: string;
  7822.  
  7823.   function NameDelimiter: Boolean;
  7824.   begin
  7825.     Result := CurChar in [' ', ',', ';', ')', #13, #10];
  7826.   end;
  7827.  
  7828.   function IsLiteral: Boolean;
  7829.   begin
  7830.     Result := CurChar in ['''', '"'];
  7831.   end;
  7832.  
  7833.   function StripLiterals(Buffer: PChar): string;
  7834.   var
  7835.     Len: Word;
  7836.     TempBuf: PChar;
  7837.  
  7838.     procedure StripChar(Value: Char);
  7839.     begin
  7840.       if TempBuf^ = Value then
  7841.         StrMove(TempBuf, TempBuf + 1, Len - 1);
  7842.       if TempBuf[StrLen(TempBuf) - 1] = Value then
  7843.         TempBuf[StrLen(TempBuf) - 1] := #0;
  7844.     end;
  7845.  
  7846.   begin
  7847.     Len := StrLen(Buffer) + 1;
  7848.     TempBuf := AllocMem(Len);
  7849.     Result := '';
  7850.     try
  7851.       StrCopy(TempBuf, Buffer);
  7852.       StripChar('''');
  7853.       StripChar('"');
  7854.       Result := StrPas(TempBuf);
  7855.     finally
  7856.       FreeMem(TempBuf, Len);
  7857.     end;
  7858.   end;
  7859.  
  7860. begin
  7861.   CurPos := Value;
  7862.   Literal := False;
  7863.   EmbeddedLiteral := False;
  7864.   repeat
  7865.     CurChar := CurPos^;
  7866.     if (CurChar = ':') and not Literal and ((CurPos + 1)^ <> ':') then
  7867.     begin
  7868.       StartPos := CurPos;
  7869.       while (CurChar <> #0) and (Literal or not NameDelimiter) do
  7870.       begin
  7871.         Inc(CurPos);
  7872.         CurChar := CurPos^;
  7873.         if IsLiteral then
  7874.         begin
  7875.           Literal := Literal xor True;
  7876.           if CurPos = StartPos + 1 then EmbeddedLiteral := True;
  7877.         end;
  7878.       end;
  7879.       CurPos^ := #0;
  7880.       if EmbeddedLiteral then
  7881.       begin
  7882.         Name := StripLiterals(StartPos + 1);
  7883.         EmbeddedLiteral := False;
  7884.       end
  7885.       else Name := StrPas(StartPos + 1);
  7886.       if Assigned(List) then
  7887.         List.CreateParam(ftUnknown, Name, ptUnknown);
  7888.       CurPos^ := CurChar;
  7889.       StartPos^ := '?';
  7890.       Inc(StartPos);
  7891.       StrMove(StartPos, CurPos, StrLen(CurPos) + 1);
  7892.       CurPos := StartPos;
  7893.     end
  7894.     else if (CurChar = ':') and not Literal and ((CurPos + 1)^ = ':') then
  7895.       StrMove(CurPos, CurPos + 1, StrLen(CurPos) + 1)
  7896.     else if IsLiteral then Literal := Literal xor True;
  7897.     Inc(CurPos);
  7898.   until CurChar = #0;
  7899. end;
  7900.  
  7901. function TQuery.CreateCursor(GenHandle: Boolean): HDBICur;
  7902. begin
  7903.   if SQL.Count > 0 then
  7904.   begin
  7905.     SetPrepared(True);
  7906.     if FDataLink.DataSource <> nil then SetParamsFromCursor;
  7907.     Result := GetQueryCursor(GenHandle);
  7908.   end else
  7909.   begin
  7910.     DatabaseError(SEmptySQLStatement);
  7911.     Result := nil;
  7912.   end;
  7913. end;
  7914.  
  7915. function TQuery.CreateHandle: HDBICur;
  7916. begin
  7917.   Result := CreateCursor(True)
  7918. end;
  7919.  
  7920. procedure TQuery.ExecSQL;
  7921. begin
  7922.   CheckInActive;
  7923.   SetDBFlag(dbfExecSQL, True);
  7924.   try
  7925.     CreateCursor(False);
  7926.   finally
  7927.     SetDBFlag(dbfExecSQL, False);
  7928.   end;
  7929. end;
  7930.  
  7931. function TQuery.GetQueryCursor(GenHandle: Boolean): HDBICur;
  7932. var
  7933.   PCursor: phDBICur;
  7934. begin
  7935.   Result := nil;
  7936.   if GenHandle then PCursor := @Result
  7937.   else PCursor := nil;
  7938.   if FParams.Count > 0 then SetParams;
  7939.   Check(DbiQExec(StmtHandle, PCursor));
  7940. end;
  7941.  
  7942. procedure TQuery.SetParams;
  7943. var
  7944.   I: Integer;
  7945.   NumBytes: Word;
  7946.   FieldDesc: PFLDDesc;
  7947.   DescBuffer: PFieldDescList;
  7948.   RecBuffer: PChar;
  7949.   CurPtr, NullPtr: PChar;
  7950.   DrvName: DBINAME;
  7951.   DrvLocale: TLocale;
  7952. begin
  7953.   DescBuffer := AllocMem(FParams.Count * SizeOf(FLDDesc));
  7954.   FieldDesc := PFLDDesc(DescBuffer);
  7955.   NumBytes := 2;
  7956.   DrvName[0] := #0;
  7957.   DrvLocale := nil;
  7958.   DbiGetProp(HDBIOBJ(StmtHandle), stmtLANGDRVNAME, @DrvName, SizeOf(DrvName), NumBytes);
  7959.   if StrLen(DrvName) > 0 then OsLdLoadBySymbName(DrvName, DrvLocale);
  7960.   try
  7961.     for I := 0 to FParams.Count - 1 do
  7962.       Inc(NumBytes, Params[I].RecBufDataSize);
  7963.     RecBuffer := AllocMem(NumBytes);
  7964.     NullPtr := RecBuffer + NumBytes - 2;
  7965.     Smallint(Pointer(NullPtr)^) := -1;
  7966.     CurPtr := RecBuffer;
  7967.     try
  7968.       for I := 0 to FParams.Count - 1 do
  7969.         with FieldDesc^, Params[I] do
  7970.         begin
  7971.           iFldType := FldTypeMap[DataType];
  7972.           if iFldType = fldUNKNOWN then
  7973.             DatabaseErrorFmt(SNoParameterValue, [Name]);
  7974.           iFldNum := I + 1;
  7975.           iLen := RecBufDataSize;
  7976.           RecBufGetData(CurPtr, DrvLocale);
  7977.           iOffset := CurPtr - RecBuffer;
  7978.           if IsNull then
  7979.             iNullOffset := NullPtr - RecBuffer
  7980.           else if iFldType = fldZString then
  7981.             iUnits1 := Length(FData)
  7982.           else if iFldType = fldBlob then
  7983.             iSubType := FldSubTypeMap[DataType];
  7984.           Inc(CurPtr, iLen);
  7985.           Inc(FieldDesc);
  7986.         end;
  7987.       Check(DbiQSetParams(StmtHandle, FParams.Count,
  7988.         PFLDDesc(DescBuffer), RecBuffer));
  7989.     finally
  7990.       FreeMem(RecBuffer, NumBytes);
  7991.     end;
  7992.   finally
  7993.     FreeMem(DescBuffer, FParams.Count * SizeOf(FLDDesc));
  7994.     if DrvLocale <> nil then OsLdUnloadObj(DrvLocale);
  7995.   end;
  7996. end;
  7997.  
  7998. procedure TQuery.SetDBFlag(Flag: Integer; Value: Boolean);
  7999. var
  8000.   NewConnection: Boolean;
  8001. begin
  8002.   if Value then
  8003.   begin
  8004.     NewConnection := DBFlags = [];
  8005.     inherited SetDBFlag(Flag, Value);
  8006.     if not (csReading in ComponentState) and NewConnection then
  8007.       FLocal := not Database.IsSQLBased;
  8008.   end
  8009.   else begin
  8010.     if DBFlags - [Flag] = [] then SetPrepared(False);
  8011.     inherited SetDBFlag(Flag, Value);
  8012.   end;
  8013. end;
  8014.  
  8015. procedure TQuery.PrepareSQL(Value: PChar);
  8016. begin
  8017.   GetStatementHandle(Value);
  8018.   if not Local then
  8019.     Check(DBiSetProp(hDbiObj(StmtHandle), stmtUNIDIRECTIONAL, LongInt(FUniDirectional)));
  8020. end;
  8021.  
  8022. procedure TQuery.GetStatementHandle(SQLText: PChar);
  8023. const
  8024.   DataType: array[Boolean] of LongInt = (Ord(wantCanned), Ord(wantLive));
  8025. begin
  8026.   Check(DbiQAlloc(DBHandle, qrylangSQL, FStmtHandle));
  8027.   try
  8028.     Check(DBiSetProp(hDbiObj(StmtHandle), stmtLIVENESS,
  8029.       DataType[RequestLive and not ForceUpdateCallback]));
  8030.     if Local then
  8031.     begin
  8032.       Check(DBiSetProp(hDbiObj(StmtHandle), stmtAUXTBLS, LongInt(False)));
  8033.       if RequestLive and Constrained then
  8034.         Check(DBiSetProp(hDbiObj(StmtHandle), stmtCONSTRAINED, LongInt(True)));
  8035.       Check(DbiSetProp(hDbiObj(StmtHandle), stmtCANNEDREADONLY, LongInt(True)));
  8036.     end;
  8037.     while not CheckOpen(DbiQPrepare(FStmtHandle, SQLText)) do
  8038.       {Retry};
  8039.   except
  8040.     DbiQFree(FStmtHandle);
  8041.     FStmtHandle := nil;
  8042.     raise;
  8043.   end;
  8044. end;
  8045.  
  8046. function TQuery.GetRowsAffected: Integer;
  8047. var
  8048.   Length: Word;
  8049. begin
  8050.   if Prepared then
  8051.     if DbiGetProp(hDBIObj(StmtHandle), stmtROWCOUNT, @Result, SizeOf(Result),
  8052.       Length) <> 0 then
  8053.       Result := -1
  8054.     else
  8055.   else Result := FRowsAffected;
  8056. end;
  8057.  
  8058. { TUpdateSQL }
  8059.  
  8060. constructor TUpdateSQL.Create(AOwner: TComponent);
  8061. var
  8062.   UpdateKind: TUpdateKind;
  8063. begin
  8064.   inherited Create(AOwner);
  8065.   for UpdateKind := Low(TUpdateKind) to High(TUpdateKind) do
  8066.   begin
  8067.     FSQLText[UpdateKind] := TStringList.Create;
  8068.     TStringList(FSQLText[UpdateKind]).OnChange := SQLChanged;
  8069.   end;
  8070. end;
  8071.  
  8072. destructor TUpdateSQL.Destroy;
  8073. var
  8074.   UpdateKind: TUpdateKind;
  8075. begin
  8076.   if Assigned(FDataSet) and (FDataSet.UpdateObject = Self) then
  8077.     FDataSet.UpdateObject := nil;
  8078.   for UpdateKind := Low(TUpdateKind) to High(TUpdateKind) do
  8079.     FSQLText[UpdateKind].Free;
  8080.   inherited Destroy;
  8081. end;
  8082.  
  8083. procedure TUpdateSQL.ExecSQL(UpdateKind: TUpdateKind);
  8084. begin
  8085.   with Query[UpdateKind] do
  8086.   begin
  8087.     Prepare;
  8088.     ExecSQL;
  8089.     if RowsAffected <> 1 then DatabaseError(SUpdateFailed);
  8090.   end;
  8091. end;
  8092.  
  8093. function TUpdateSQL.GetQuery(UpdateKind: TUpdateKind): TQuery;
  8094. begin
  8095.   if not Assigned(FQueries[UpdateKind]) then
  8096.   begin
  8097.     FQueries[UpdateKind] := TQuery.Create(Self);
  8098.     FQueries[UpdateKind].SQL.Assign(FSQLText[UpdateKind]);
  8099.     if (FDataSet is TDBDataSet) then
  8100.     begin
  8101.       FQueries[UpdateKind].SessionName := TDBDataSet(FDataSet).SessionName;
  8102.       FQueries[UpdateKind].DatabaseName := TDBDataSet(FDataSet).DataBaseName;
  8103.     end;
  8104.   end;
  8105.   Result := FQueries[UpdateKind];
  8106. end;
  8107.  
  8108. function TUpdateSQL.GetSQL(UpdateKind: TUpdateKind): TStrings;
  8109. begin
  8110.   Result := FSQLText[UpdateKind];
  8111. end;
  8112.  
  8113. function TUpdateSQL.GetSQLIndex(Index: Integer): TStrings;
  8114. begin
  8115.   Result := FSQLText[TUpdateKind(Index)];
  8116. end;
  8117.  
  8118. function TUpdateSQL.GetDataSet: TBDEDataSet;
  8119. begin
  8120.   Result := FDataSet;
  8121. end;
  8122.  
  8123. procedure TUpdateSQL.SetDataSet(ADataSet: TBDEDataSet);
  8124. begin
  8125.   FDataSet := ADataSet;
  8126. end;
  8127.  
  8128. procedure TUpdateSQL.SetSQL(UpdateKind: TUpdateKind; Value: TStrings);
  8129. begin
  8130.   FSQLText[UpdateKind].Assign(Value);
  8131. end;
  8132.  
  8133. procedure TUpdateSQL.SetSQLIndex(Index: Integer; Value: TStrings);
  8134. begin
  8135.   SetSQL(TUpdateKind(Index), Value);
  8136. end;
  8137.  
  8138. procedure TUpdateSQL.SQLChanged(Sender: TObject);
  8139. var
  8140.   UpdateKind: TUpdateKind;
  8141. begin
  8142.   for UpdateKind := Low(TUpdateKind) to High(TUpdateKind) do
  8143.     if Sender = FSQLText[UpdateKind] then
  8144.     begin
  8145.       if Assigned(FQueries[UpdateKind]) then
  8146.       begin
  8147.         FQueries[UpdateKind].Params.Clear;
  8148.         FQueries[UpdateKind].SQL.Assign(FSQLText[UpdateKind]);
  8149.       end;
  8150.       Break;
  8151.     end;
  8152. end;
  8153.  
  8154. procedure TUpdateSQL.SetParams(UpdateKind: TUpdateKind);
  8155. var
  8156.   I: Integer;
  8157.   Old: Boolean;
  8158.   Param: TParam;
  8159.   PName: string;
  8160.   Field: TField;
  8161. begin
  8162.   if not Assigned(FDataSet) then Exit;
  8163.   with Query[UpdateKind] do
  8164.   begin
  8165.     for I := 0 to Params.Count - 1 do
  8166.     begin
  8167.       Param := Params[I];
  8168.       PName := Param.Name;
  8169.       Old := CompareText(Copy(PName, 1, 4), 'OLD_') = 0;
  8170.       if Old then System.Delete(PName, 1, 4);
  8171.       Field := FDataSet.FindField(PName);
  8172.       if not Assigned(Field) then Continue;
  8173.       if Old then
  8174.         Param.AssignFieldValue(Field, Field.OldValue) else
  8175.         Param.AssignFieldValue(Field, Field.NewValue);
  8176.     end;
  8177.   end;
  8178. end;
  8179.  
  8180. procedure TUpdateSQL.Apply(UpdateKind: TUpdateKind);
  8181. begin
  8182.   SetParams(UpdateKind);
  8183.   ExecSQL(UpdateKind);
  8184. end;
  8185.  
  8186. { TBlobStream }
  8187.  
  8188. constructor TBlobStream.Create(Field: TBlobField; Mode: TBlobStreamMode);
  8189. var
  8190.   OpenMode: DbiOpenMode;
  8191. begin
  8192.   FMode := Mode;
  8193.   FField := Field;
  8194.   FDataSet := FField.DataSet as TBDEDataSet;
  8195.   FFieldNo := FField.FieldNo;
  8196.   if not FDataSet.GetActiveRecBuf(FBuffer) then Exit;
  8197.   if FDataSet.State = dsFilter then
  8198.     DatabaseErrorFmt(SNoFieldAccess, [FField.DisplayName]);
  8199.   if not FField.Modified then
  8200.   begin
  8201.     if Mode = bmRead then
  8202.     begin
  8203.       FCached := FDataSet.FCacheBlobs and (FBuffer = FDataSet.ActiveBuffer) and
  8204.         ({!FField.IsNull or }(FDataSet.GetBlobData(FField, FBuffer) <> ''));
  8205.       OpenMode := dbiReadOnly;
  8206.     end else
  8207.     begin
  8208.       FDataSet.SetBlobData(FField, FBuffer, '');
  8209.       if FField.ReadOnly then DatabaseErrorFmt(SFieldReadOnly, [FField.DisplayName]);
  8210.       if not (FDataSet.State in [dsEdit, dsInsert]) then DatabaseError(SNotEditing);
  8211.       OpenMode := dbiReadWrite;
  8212.     end;
  8213.     if not FCached then
  8214.       Check(DbiOpenBlob(FDataSet.Handle, FBuffer, FFieldNo, OpenMode));
  8215.   end;
  8216.   FOpened := True;
  8217.   if Mode = bmWrite then Truncate;
  8218. end;
  8219.  
  8220. destructor TBlobStream.Destroy;
  8221. begin
  8222.   if FOpened then
  8223.   begin
  8224.     if FModified then FField.Modified := True;
  8225.     if not FField.Modified and not FCached then
  8226.       DbiFreeBlob(FDataSet.Handle, FBuffer, FFieldNo);
  8227.   end;
  8228.   if FModified then
  8229.   try
  8230.     FDataSet.DataEvent(deFieldChange, Longint(FField));
  8231.   except
  8232.     Application.HandleException(Self);
  8233.   end;
  8234. end;
  8235.  
  8236. function TBlobStream.Read(var Buffer; Count: Longint): Longint;
  8237. var
  8238.   Status: DBIResult;
  8239. begin
  8240.   Result := 0;
  8241.   if FOpened then
  8242.   begin
  8243.     if FCached then
  8244.     begin
  8245.       if Count > Size - FPosition then
  8246.         Result := Size - FPosition else
  8247.         Result := Count;
  8248.       if Result > 0 then
  8249.       begin
  8250.         Move(PChar(FDataSet.GetBlobData(FField, FBuffer))[FPosition], Buffer, Result);
  8251.         Inc(FPosition, Result);
  8252.       end;
  8253.     end else
  8254.     begin
  8255.       Status := DbiGetBlob(FDataSet.Handle, FBuffer, FFieldNo, FPosition,
  8256.         Count, @Buffer, Result);
  8257.       case Status of
  8258.         DBIERR_NONE, DBIERR_ENDOFBLOB:
  8259.           begin
  8260.             if FField.Transliterate then
  8261.               NativeToAnsiBuf(FDataSet.Locale, @Buffer, @Buffer, Result);
  8262.             if FDataset.FCacheBlobs and (FBuffer = FDataSet.ActiveBuffer) and
  8263.               (FMode = bmRead) and not FField.Modified and (FPosition = FCacheSize) then
  8264.             begin
  8265.               FCacheSize := FPosition + Result;
  8266.               SetLength(FBlobData, FCacheSize);
  8267.               Move(Buffer, PChar(FBlobData)[FPosition], Result);
  8268.               if FCacheSize = Size then
  8269.               begin
  8270.                 FDataSet.SetBlobData(FField, FBuffer, FBlobData);
  8271.                 FBlobData := '';
  8272.                 FCached := True;
  8273.                 DbiFreeBlob(FDataSet.Handle, FBuffer, FFieldNo);
  8274.               end;
  8275.             end;
  8276.             Inc(FPosition, Result);
  8277.           end;
  8278.         DBIERR_INVALIDBLOBOFFSET:
  8279.           {Nothing};
  8280.       else
  8281.         DbiError(Status);
  8282.       end;
  8283.     end;
  8284.   end;
  8285. end;
  8286.  
  8287. function TBlobStream.Write(const Buffer; Count: Longint): Longint;
  8288. var
  8289.   Temp: Pointer;
  8290. begin
  8291.   Result := 0;
  8292.   if FOpened then
  8293.   begin
  8294.     if FField.Transliterate then
  8295.     begin
  8296.       GetMem(Temp, Count);
  8297.       try
  8298.         AnsiToNativeBuf(FDataSet.Locale, @Buffer, Temp, Count);
  8299.         Check(DbiPutBlob(FDataSet.Handle, FBuffer, FFieldNo, FPosition,
  8300.           Count, Temp));
  8301.       finally
  8302.         FreeMem(Temp, Count);
  8303.       end;
  8304.     end else
  8305.       Check(DbiPutBlob(FDataSet.Handle, FBuffer, FFieldNo, FPosition,
  8306.         Count, @Buffer));
  8307.     Inc(FPosition, Count);
  8308.     Result := Count;
  8309.     FModified := True;
  8310.     FDataSet.SetBlobData(FField, FBuffer, '');
  8311.   end;
  8312. end;
  8313.  
  8314. function TBlobStream.Seek(Offset: Longint; Origin: Word): Longint;
  8315. begin
  8316.   case Origin of
  8317.     0: FPosition := Offset;
  8318.     1: Inc(FPosition, Offset);
  8319.     2: FPosition := GetBlobSize + Offset;
  8320.   end;
  8321.   Result := FPosition;
  8322. end;
  8323.  
  8324. procedure TBlobStream.Truncate;
  8325. begin
  8326.   if FOpened then
  8327.   begin
  8328.     Check(DbiTruncateBlob(FDataSet.Handle, FBuffer, FFieldNo, FPosition));
  8329.     FModified := True;
  8330.     FDataSet.SetBlobData(FField, FBuffer, '');
  8331.   end;
  8332. end;
  8333.  
  8334. function TBlobStream.GetBlobSize: Longint;
  8335. begin
  8336.   Result := 0;
  8337.   if FOpened then
  8338.     if FCached then
  8339.       Result := Length(FDataSet.GetBlobData(FField, FBuffer)) else
  8340.       Check(DbiGetBlobSize(FDataSet.Handle, FBuffer, FFieldNo, Result));
  8341. end;
  8342.  
  8343. initialization
  8344.   CoInitialize(nil);
  8345.   Sessions := TSessionList.Create;
  8346.   Session := TSession.Create(nil);
  8347.   Session.SessionName := 'Default'; { Do not localize }
  8348. finalization
  8349.   Sessions.Free;
  8350.   BDEInitProcs.Free;
  8351.   FreeTimer;
  8352.   CoUninitialize;
  8353. end.
  8354.